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

Question

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!

Answer 1

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]