2
$\begingroup$

I'm trying to draw the region where the next inequality is true : $$ r_1 \tau-r_3 \int^{\tau}_{0} C_s(t)<0$$where $$C_s(t)=e^{t-r_5 t} \left(d e^{r_8 \tau }+e^{r_8 (t+\tau )}-e^{r_8 t}\right){}^{-\frac{1}{r_8}} \left(\int_1^t r_4 e^{\xi \left(r_5-1\right)} \left(d e^{r_8 \tau }+e^{\xi r_8} \left(e^{r_8 \tau }-1\right)\right){}^{\frac{1}{r_8}} \, d\xi -\int_1^0 r_4 e^{\xi \left(r_5-1\right)} \left(d e^{r_8 \tau }+e^{\xi r_8} \left(e^{r_8 \tau }-1\right)\right){}^{\frac{1}{r_8}} \, d\xi \right) $$ varying the parameters $\tau$ and $d$, with $ r_5$ and $r_8$ fixed. Since i have not been able to solve the integrals explicitly I'm using NIntegrate to evaluate it. First i have definition of $C_s$ like this

Subscript[C, s][t_, \[Tau]_, d_] := (E^(t - t*Subscript[r, 5])*
(-Integrate[E^(\[Xi]*(-1 + Subscript[r, 5]))*(d*E^(\[Tau]*Subscript[r, 8]) + 
      E^(\[Xi]*Subscript[r, 8])*(-1 + E^(\[Tau]*Subscript[r, 8])))^(1/Subscript[r, 8])*
    Subscript[r, 4], {\[Xi], 1, 0}] + Integrate[E^(\[Xi]*(-1 + Subscript[r, 5]))*
   (d*E^(\[Tau]*Subscript[r, 8]) + E^(\[Xi]*Subscript[r, 8])*
      (-1 + E^(\[Tau]*Subscript[r, 8])))^(1/Subscript[r, 8])*Subscript[r, 4], 
  {\[Xi], 1, t}]))/(-E^(t*Subscript[r, 8]) + d*E^(\[Tau]*Subscript[r, 8]) + 
 E^((t + \[Tau])*Subscript[r, 8]))^(1/Subscript[r, 8])

then in order to evaluate $\int^{\tau}_{0} C(t)$ I create the function:

Subscript[r, 1] = 0.00029938135;
Subscript[r, 3] = 2.507341314*^-8;
Subscript[r, 5] = 0.005435396430;
Subscript[r, 8] = 0.5761520216;
Subscript[r, 4] = 0.00001129433024;
NIntCs[\[Tau]_, d_] := 
     NIntegrate[Subscript[C, s][t, \[Tau], d], {t, 0, \[Tau]}]

. Which allows me to evaluate the integral $\int^{\tau}_{0} C_s(t)$ for example, from $0$ to $\tau=48$ with $d=10^8$ :

 In[94]:=
NIntCs[48, 10^8]

Out[94]= 1.02318*10^10

Now if if execute RegionPlot to see the inequality

RegionPlot[Subscript[r, 1]*\[Tau] - Subscript[r, 3]*NIntCs[\[Tau], d] < 0, {\[Tau], 0, 10}, {d, 0, 10}]

Throws :

In[93]:=
RegionPlot[Subscript[r, 1]*\[Tau] - Subscript[r, 3]*NIntCs[\[Tau], d] < 0, {\[Tau], 0, 10}, 
  {d, 0, 10}]

During evaluation of In[93]:= Throw::nocatch: Uncaught Throw[False] returned to top level. >>

During evaluation of In[93]:= Throw::nocatch: Uncaught Throw[False] returned to top level. >>

During evaluation of In[93]:= Throw::nocatch: Uncaught Throw[0.193382 +0.372841 $Failed] returned to top level. >>

During evaluation of In[93]:= General::stop: Further output of Throw::nocatch will be suppressed during this calculation. >>

Out[93]= Hold[Throw[False], Throw[False], Throw[0.193382 + 0.372841 $Failed], 
 Throw[False], Throw[False], Throw[0.28262 + 0.751145 $Failed], 
 Throw[0.97354 + 0.370967 $Failed], Throw[0.158068 + 0.405859 $Failed], 
 Throw[0.591793 + 0.932639 $Failed], Throw[0.0379657 + 0.669591 $Failed], 
 Throw[{{-433906005514 + 753110271565 Reduce`ReduceVar[3], 
    Reduce`ReduceVar[2], 
    433906005514 - 
     753110271565 Reduce`ReduceVar[1], -1 + \[Tau]}, {{-433906005514 + 
      753110271565 Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {-433906005514 + 753110271565 Reduce`ReduceVar[1], 
     1, Reduce`ReduceVar[1]}, {-1 + \[Tau], 1, \[Tau]}}}], 
 Throw[{{Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1], \[Tau]}, {{Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1], 1, 
     Reduce`ReduceVar[1]}, {\[Tau], 1, \[Tau]}}}], 
 Throw[{{-433906005514 + 753110271565 Reduce`ReduceVar[3], 
    Reduce`ReduceVar[2], 
    433906005514 - 
     753110271565 Reduce`ReduceVar[1], -1 + \[Tau]}, {{-433906005514 + 
      753110271565 Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {-433906005514 + 753110271565 Reduce`ReduceVar[1], 
     1, Reduce`ReduceVar[1]}, {-1 + \[Tau], 1, \[Tau]}}}], 
 Throw[0.55161 + 0.751459 $Failed], Throw[0.839512 + 0.769479 $Failed], 
 Throw[0.0342406 + 0.286654 $Failed], Throw[0.367282 + 0.209207 $Failed], 
 Throw[0.543596 + 0.737445 $Failed], Throw[0.588095 + 0.707536 $Failed], 
 Throw[{{Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1] - Reduce`ReduceVar[3], -1 + t, 
    433906005514 \[Tau] - 
     753110271565 Reduce`ReduceVar[3]}, {{Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1] - Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[1]}, {-1 + t, 1, 
     t}, {433906005514 \[Tau] - 753110271565 Reduce`ReduceVar[3], 
     1, \[Tau]}}}], 
 Throw[{{Reduce`ReduceVar[4], Reduce`ReduceVar[3], Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1], \[Xi]}, {{Reduce`ReduceVar[4], 1, 
     Reduce`ReduceVar[4]}, {Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1], 1, 
     Reduce`ReduceVar[1]}, {\[Xi], 1, \[Xi]}}}], 
 Throw[{{Reduce`ReduceVar[1], 
    t}, {{Reduce`ReduceVar[1], 1, Reduce`ReduceVar[1]}, {t, 1, t}}}], 
 Throw[{{Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1] - Reduce`ReduceVar[3], -1 + t, 
    433906005514 \[Tau] - 
     753110271565 Reduce`ReduceVar[3]}, {{Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1] - Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[1]}, {-1 + t, 1, 
     t}, {433906005514 \[Tau] - 753110271565 Reduce`ReduceVar[3], 
     1, \[Tau]}}}], 
 Throw[{{Reduce`ReduceVar[4], Reduce`ReduceVar[3], Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1], \[Xi]}, {{Reduce`ReduceVar[4], 1, 
     Reduce`ReduceVar[4]}, {Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1], 1, 
     Reduce`ReduceVar[1]}, {\[Xi], 1, \[Xi]}}}], 
 Throw[0.896879 + 0.796894 $Failed], Throw[0.245253 + 0.107569 $Failed], 
 Throw[-Holonomic`DifferentialRootReduceDump`y[NIntegrate`LevinRuleDump`x] + 
   Derivative[1][Holonomic`DifferentialRootReduceDump`y][
    NIntegrate`LevinRuleDump`x], 
  NIntegrate`LevinRuleDump`FastLookupHolonomicDifferentialEquation], 
 Throw[-Holonomic`DifferentialRootReduceDump`y[NIntegrate`LevinRuleDump`x] + 
   Derivative[1][Holonomic`DifferentialRootReduceDump`y][
    NIntegrate`LevinRuleDump`x], 
  NIntegrate`LevinRuleDump`FastLookupHolonomicDifferentialEquation], 
 Throw[0.100299 + 0.716852 $Failed], Throw[0.087617 + 0.15486 $Failed], 
 Throw[0.912248 + 0.262896 $Failed], Throw[0.75313 + 0.621968 $Failed], 
 Throw[{{-433906005514 + 753110271565 Reduce`ReduceVar[3], 
    Reduce`ReduceVar[2], 
    433906005514 - 
     753110271565 Reduce`ReduceVar[1], -1 + \[Tau]}, {{-433906005514 + 
      753110271565 Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {-433906005514 + 753110271565 Reduce`ReduceVar[1], 
     1, Reduce`ReduceVar[1]}, {-1 + \[Tau], 1, \[Tau]}}}], 
 Throw[{{Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1], \[Tau]}, {{Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1], 1, 
     Reduce`ReduceVar[1]}, {\[Tau], 1, \[Tau]}}}], 
 Throw[{{-433906005514 + 753110271565 Reduce`ReduceVar[3], 
    Reduce`ReduceVar[2], 
    433906005514 - 
     753110271565 Reduce`ReduceVar[1], -1 + \[Tau]}, {{-433906005514 + 
      753110271565 Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {-433906005514 + 753110271565 Reduce`ReduceVar[1], 
     1, Reduce`ReduceVar[1]}, {-1 + \[Tau], 1, \[Tau]}}}], 
 Throw[0.889982 + 0.174676 $Failed], Throw[0.350523 + 0.740018 $Failed], 
 Throw[0.65878 + 0.55734 $Failed], Throw[0.376622 + 0.257991 $Failed], 
 Throw[0.833684 + 0.0358738 $Failed], Throw[0.330488 + 0.341129 $Failed], 
 Throw[{{Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1] - Reduce`ReduceVar[3], -1 + t, 
    433906005514 \[Tau] - 
     753110271565 Reduce`ReduceVar[3]}, {{Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1] - Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[1]}, {-1 + t, 1, 
     t}, {433906005514 \[Tau] - 753110271565 Reduce`ReduceVar[3], 
     1, \[Tau]}}}], 
 Throw[{{Reduce`ReduceVar[4], Reduce`ReduceVar[3], Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1], \[Xi]}, {{Reduce`ReduceVar[4], 1, 
     Reduce`ReduceVar[4]}, {Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1], 1, 
     Reduce`ReduceVar[1]}, {\[Xi], 1, \[Xi]}}}], 
 Throw[{{Reduce`ReduceVar[1], 
    t}, {{Reduce`ReduceVar[1], 1, Reduce`ReduceVar[1]}, {t, 1, t}}}], 
 Throw[{{Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1] - Reduce`ReduceVar[3], -1 + t, 
    433906005514 \[Tau] - 
     753110271565 Reduce`ReduceVar[3]}, {{Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1] - Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[1]}, {-1 + t, 1, 
     t}, {433906005514 \[Tau] - 753110271565 Reduce`ReduceVar[3], 
     1, \[Tau]}}}], 
 Throw[{{Reduce`ReduceVar[4], Reduce`ReduceVar[3], Reduce`ReduceVar[2], 
    Reduce`ReduceVar[1], \[Xi]}, {{Reduce`ReduceVar[4], 1, 
     Reduce`ReduceVar[4]}, {Reduce`ReduceVar[3], 1, 
     Reduce`ReduceVar[3]}, {Reduce`ReduceVar[2], 1, 
     Reduce`ReduceVar[2]}, {Reduce`ReduceVar[1], 1, 
     Reduce`ReduceVar[1]}, {\[Xi], 1, \[Xi]}}}], 
 Throw[0.955508 + 0.0216473 $Failed], Throw[0.32874 + 0.738323 $Failed], 
 Throw[-Holonomic`DifferentialRootReduceDump`y[NIntegrate`LevinRuleDump`x] + 
   Derivative[1][Holonomic`DifferentialRootReduceDump`y][
    NIntegrate`LevinRuleDump`x], 
  NIntegrate`LevinRuleDump`FastLookupHolonomicDifferentialEquation], 
 Throw[-Holonomic`DifferentialRootReduceDump`y[NIntegrate`LevinRuleDump`x] + 
   Derivative[1][Holonomic`DifferentialRootReduceDump`y][
    NIntegrate`LevinRuleDump`x], 
  NIntegrate`LevinRuleDump`FastLookupHolonomicDifferentialEquation]]

How i can use RegionPlot to draw the inequality?, also speed up tips would be useful. Than you.

$\endgroup$
  • $\begingroup$ Advise that you replace C[t_, \[Tau]_, d_] := (*defined like above*) with the actual Mathematica code. Fine to have the nice pretty printed equation in addition to the Mathematica code. $\endgroup$ – Jack LaVigne Jul 5 '16 at 23:15
  • $\begingroup$ General recommendation is to avoie upper case user defined symbols. Currently I get an error with C[t_, \[Tau]_, d_] := ... $\endgroup$ – Jack LaVigne Jul 5 '16 at 23:44
  • $\begingroup$ Thank you @ Jack LaVigne i have made the changes. $\endgroup$ – JulesR Jul 5 '16 at 23:53
  • $\begingroup$ Are r1 through r8 constants? You need to supply us with the values. Is t always greater than one or between one and zero? I think you can perform one integration rather than two by changing the limits because the function inside the integral is identical. $\endgroup$ – Jack LaVigne Jul 6 '16 at 0:26
  • $\begingroup$ @ Jack LaVigne Yes, r1,r3,r5,r8 are fixed parameters. I Just added it.And for my case t is greater than 1. I'm thinking about the changing of limits. $\endgroup$ – JulesR Jul 6 '16 at 2:07
1
$\begingroup$

RegionPlot does indeed produce an error. I have contacted Wolfram support with this example.

They suggested a workaround using Plot3D and RegionFunction.

r1 = 0.00029938135; r3 = 2.507341314*^-8;
r4 = 0.00001129433024; r5 = 0.005435396430;
r8 = 0.5761520216;

cs[t_?NumericQ, τ_?NumericQ, d_?NumericQ] := Exp[t - t*r5]*
  NIntegrate[Exp[ξ*(-1 + r5)]*(d*Exp[τ*r8] + Exp[ξ*r8]*
         (-1 + Exp[τ*r8]))^(1/r8)*r4, {ξ, 0, t}]/
   (-Exp[t*r8] + d*Exp[τ*r8] + Exp[(t + τ)*r8])^(1/r8)

nIntCs[τ_?NumericQ, d_?NumericQ] := 
 NIntegrate[cs[t, τ, d], {t, 0, τ}]

The evaluation is slow but the function nIntCs plots OK.

Plot3D[
 Evaluate[nIntCs[τ, d]], {τ, -0.5, 0.5}, {d, 0, 10},
 AxesLabel -> {"τ", "d", "intCs"},
 ColorFunction -> Function[{x, y, z}, Hue[z]],
 ImageSize -> 400
 ]

Mathematica graphics

Below the expression that is used as the input to RegionPlot is displayed along with the plane z=0. Take note that the region that is less than zero is totally dominated by the term r1 τ. The product r3 NIntCs[τ, d] has virtually no effect on the result.

Show[
 Plot3D[r1 τ - r3 Evaluate[nIntCs[τ, d]],
  {τ, -0.5, 0.5}, {d, 0, 10},
  AxesLabel -> {"τ", "d", "intCs"},
  ColorFunction -> Function[{x, y, z}, Hue[z]]
  ],
 Plot3D[0, {τ, -0.5, 0.5}, {d, 0, 10},
  ColorFunction -> Function[{x, y, z}, Cyan]
  ],
 PlotRange -> All
 ]

Mathematica graphics

The workaround to RegionPlot using Plot3D and RegionFunction is shown below.

Plot3D[
 r1 τ - r3*Evaluate[NIntCs[τ, d]], 
 {τ, -0.5, 0.5}, {d, 0, 10},
  AxesLabel -> {"τ", "d", "intCs"}, 
 ColorFunction -> Function[{x, y, z}, Hue[z]],
 RegionFunction -> Function[{x, y, z},
   (r1 x - r3*Evaluate[NIntCs[x, y]] < 0)],
 ImageSize -> 400
 ]

Mathematica graphics

$\endgroup$

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.