# 4D Region Plot with multiple inequalities

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.

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]


• Thank you so much for your help! Really love this plot Commented Nov 19, 2019 at 6:24
• In this case there was a rescaling of gamma; is it possible to make a colored picture like this if we would not have the alfa+beta+sigma+gamma=1?
– R.W
Commented Feb 12, 2020 at 15:23
• @RafaelWagner - A constraint on gamma in terms of {alpha, beta, gamma} is what enables reducing the inequalities to a 3D implicit region in {alpha, beta, gamma}. Without a defined 3D region, coloring is not possible. Commented Feb 12, 2020 at 17:25