# 3D-Plot optimization results for varying parameter values

Before starting, FYI: This is a question related to 3D Plot the result of local Minimize with varying parameter values

Consider my objective function, $$objF$$:

objF=1/(2 s^2) (2 (-k + s) (d^2 - d s - ((d - s) ((-1 + d) k^2 r + c (2 d^2 (-1 + q) + k^2 (-1 + 2 q) r + 2 d s) - s (-2 (-1 + d) d + d s + s^2)) (-1 + t))/(2 s^2) - d t + s t) - (d^3 - 2 d^2 s + d s^2 - ((d - s)^2 (6 c d^2 (-1 + q) + 3 k^2 (-1 + d + c (-1 + 2 q)) r + 6 d (-1 + c + d) s - 4 d s^2 - 2 s^3) (-1 + t))/(6 s^2) - d^2 t + 2 d s t - s^2 t)/r)


with parameter values: $$t=0.2$$, $$s=2$$, $$d=0.8$$ and $$k < d$$, $$k \geq 0$$, $$0 \leq r \leq 1$$, $$0 \leq c \leq 1$$, and $$q \geq 1$$.

I'm trying to maximize the above objective function with respect to $$r$$ and $$k$$.

Eventually, I would like to Plot3D each of the optimal values of $$objF$$, $$r$$, and $$k$$ against $$c$$ and $$q$$.

My mathematica codes are as follows.

First, for $$objF$$:

max = MaxValue[{objF, k < d, k >= 0, 0 <= d <= 1, 2 d < s, 0 <= r <= 1, 0 <= t <= 1, 0 <= c <= 1, q >= 1}, {k, r}]
Plot3D[max, {c, 0, 1}, {q, 1, 2}, PlotRange -> All, AxesLabel -> {c, q, max}]


Second, for $$r$$:

maxR = Last@Last@Maximize[{objF, k < d, k >= 0, 0 <= d <= 1, 2 d < s, 0 <= r <= 1, 0 <= t <= 1, 0 <= c <= 1, q >= 1}, {k, r}]
Plot3D[r/.maxR, {c, 0, 1}, {q, 1, 2}, PlotRange -> All, AxesLabel -> {c, q, r}]


Third, for $$k$$:

maxK = First@Last@Maximize[{objF, k < d, k >= 0, 0 <= d <= 1, 2 d < s, 0 <= r <= 1, 0 <= t <= 1, 0 <= c <= 1, q >= 1}, {k, r}]
Plot3D[k/.maxK, {c, 0, 1}, {q, 1, 2}, PlotRange -> All, AxesLabel -> {c, q, k}]


These are not working properly. Can anyone help please? Thank you!

• It is necessary to determine the parameters d, s, t at the beginning of the code. – Alex Trounev May 7 '19 at 11:07
• @Alex Trounev: I have corrected the silly mistake of forgetting to specify the value of t,s,d. Thanks for pointing this out! – ppp May 7 '19 at 13:06
• There is $1/r$ and $r$ starts with r = 0. Therefore, with these parameters, the maximum=ComplexInfinity is reached at r = 0. – Alex Trounev May 7 '19 at 21:17
• @Alex Trounev: Thanks! My followup question is, how do we know that the numerator of the term with $\frac{1}{r}$ is positive? If it is negative, then the maximum is reached at r=1, no? – ppp May 7 '19 at 21:26
• Yes, this is also possible, $r= 1$ included. But in 3D it looks awful. – Alex Trounev May 7 '19 at 22:23

I use the numerical method, but because of the singularity $$1/r$$, I have to trim $$r$$, for example, start with $$r=r0, r0=10^{-3}$$. This value is selected to avoid messages.

Block[{d = .8, s = 2, t = .2, r0 = 10^-3},
objF = 1/(2 s^2) (2 (-k + s) (d^2 -
d s - ((d - s) ((-1 + d) k^2 r +
c (2 d^2 (-1 + q) + k^2 (-1 + 2 q) r + 2 d s) -
s (-2 (-1 + d) d + d s + s^2)) (-1 + t))/(2 s^2) - d t +
s t) - (d^3 - 2 d^2 s +
d s^2 - ((d - s)^2 (6 c d^2 (-1 + q) +
3 k^2 (-1 + d + c (-1 + 2 q)) r + 6 d (-1 + c + d) s -
4 d s^2 - 2 s^3) (-1 + t))/(6 s^2) - d^2 t + 2 d s t -
s^2 t)/r);
max = Flatten[
Table[{c, q,
MaxValue[{objF, 0 <= k < d, r0 <= r <= 1}, {k, r}]}, {c, 0,
1, .1}, {q, 1, 2, .1}], 1];
maxk = Flatten[
Table[{c, q,
k /. Last@
Maximize[{objF, 0 <= k < d, r0 <= r <= 1}, {k, r}]}, {c, 0,
1, .1}, {q, 1, 2, .1}], 1];
maxr = Flatten[
Table[{c, q,
r /. Last@
Maximize[{objF, 0 <= k < d, r0 <= r <= 1}, {k, r}]}, {c, 0,
1, .1}, {q, 1, 2, .1}], 1];]
{ListPlot3D[max, AxesLabel -> {"c", "q", "max"}],
ListPlot3D[maxk, AxesLabel -> {"c", "q", "maxK"}],
ListPlot3D[maxr, AxesLabel -> {"c", "q", "maxR"}]}


• I have tried your solution with another objective function, which however generates some errors. I have create a new post for this question: mathematica.stackexchange.com/questions/200232/… Can you please help once more? – ppp Jun 12 '19 at 17:43
• Hello Alex, I am applying your solution in an extended case where the objective function now takes three different expressions depending on the constraints. May I ask for your help once more? I really really appreciate! My new post is here: mathematica.stackexchange.com/questions/201823/… – ppp Jul 9 '19 at 21:21