2
$\begingroup$

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!

$\endgroup$

1 Answer 1

6
$\begingroup$
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]]

enter image description here

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]]

enter image description here

Δ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]

enter image description here

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

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.