# Plotting a 4-dimensional graph with the fourth dimension depicted using a color scheme

I wish to use Mathematica to plot a 4-D graph of R0 (basic reproduction number of a disease) against three given parameters in which the three parameters are represented by the x-, y-, and z- axes and R0 is represented by a color scheme. So, the graph will essentially look like a 3-dimensional graph, but the fourth dimension (illustrating R0) should be in terms of a color scheme.

In the current model, I wanted to plot R0 against the three parameters beta, p, and phi which all vary between 0 and 1. The formula for R0 and the parameters are given below.

c = 0.01;
gamma = 0.2;
theta = 0.2778;
epsilon = 0.084;
delta = 0.011;
mu = 0.000027;

R0 = (epsilon*c*beta*theta*(mu+(1-phi)*p))/(mu*(mu+p)*(mu+epsilon)*(mu+gamma+delta))


Any help on this would be highly valued. Thank you for your time!

Clear["Global*"]

c = 1/100;
gamma = 1/5;
theta = 1389/5000;
epsilon = 21/250;
delta = 11*^-3;
mu = 27*^-6;

R0[beta_, p_,
phi_] = (epsilon*c*beta*
theta*(mu + (1 - phi)*p))/(mu*(mu + p)*(mu + epsilon)*(mu +
gamma + delta)) // Simplify;


The range of R0 is

({min, max} = #[{R0[beta, p, phi], 0 <= beta <= 1, 0 <= p <= 1,
0 <= phi <= 1}, {beta, p, phi}] & /@ {MinValue, MaxValue}) /.
r_Rational :> N[r]

(* {0, 487.406} *)

Δ = 0.1;

data = Flatten[
Table[
{beta, p, phi, R0[beta, p, phi]},
{beta, 0, 1, Δ}, {p, 0, 1, Δ}, {phi,
0, 1, Δ}],
2];


EDIT: Corrected scaling for data

ListPointPlot3D[data[[All, ;; 3]],
AxesLabel -> (Style[#, 14] & /@ {beta, p, phi}),
ColorFunction ->
Function[{beta, p, phi},
Evaluate@ColorData["Rainbow"][R0[beta, p, phi]/max]],
PlotLegends -> BarLegend[{"Rainbow", {min, max}}, LegendLabel -> R0]]


To delete data for which R0 > 5

Δ3 = 0.05;

data3 = Flatten[
Table[{beta, p, phi, R0[beta, p, phi]}, {beta, 0, 1, Δ3},
{p, 0, 1, Δ3}, {phi, 0, 1, Δ3}], 2];

ListPointPlot3D[Select[data3, #[[-1]] <= 5 &][[All, ;; 3]],
AxesLabel -> (Style[#, 14] & /@ {beta, p, phi}),
ColorFunction ->
Function[{beta, p, phi}, Evaluate@
ColorData["Rainbow"][R0[beta, p, phi]/5]],
PlotLegends -> BarLegend[{"Rainbow", {min, 5}},
LegendLabel -> R0]]


Δ2 = 0.01;


Similarly limiting the range of R0 for data2

data2 = Select[
Flatten[
Table[{beta, p, phi, R0[beta, p, phi]}, {beta, 0,
1, Δ2}, {p, 0, 1, Δ2}, {phi, 0,
1, Δ2}], 2],
#[[-1]] <= 5 &];


Plotting with ListDensityPlot3D

ListDensityPlot3D[data2,
PlotLegends -> Automatic]
`

• Thanks a lot, @Bob Hanlon! This is great. Could you also explain how to restrict R0 between 0 and 5? Jan 15, 2023 at 21:15
• Limit in what sense? Hard limit? Or delete values outside the range? Jan 15, 2023 at 21:48
• Yes, deleting the values outside of the range. Jan 15, 2023 at 21:54
• Corrected scaling for first plot and trimmed data to R0 <= 5 Jan 16, 2023 at 1:31
• Thank you so much! Jan 16, 2023 at 3:07