# How do to create 3D plot for the argument from two another arguments for maximum of the function?

How do to create 3D plot of $${t_{opt}} = {f_2}\left( {x,y} \right)$$, where $${t_{opt}}$$ is corresponding to maximum value of $${f_1}\left( {x,y,t} \right)$$ at the limited ranges of $$x,y,t$$? If $$t$$ cannot be found directly from $$\frac{{\partial {f_1}\left( {x,y,t} \right)}}{{\partial t}} = 0$$.

For example $${f_1}\left( {x,y,t} \right) = \left| {\cos \left( t \right)} \right|\left( {\sin \left( x \right) + \cos \left( y \right)} \right) + \frac{{\sqrt t }}{{\ln \left( t \right)}}$$ $$x \in \left[ {0;10} \right],y \in \left[ {0;10} \right],t \in \left[ {2;10} \right]$$

I try to use this code

f1 = Abs[Cos[t]] (Sin[x] + Cos[y]) + Sqrt[t]/Log[t]
dfdt = Simplify[D[f1, t]]
tOpt = NSolve[dfdt == 0, t]
tOpt = tOpt[[1]][[1]][[2]]
Plot3D[tOpt, {x, 0, 10}, {y, 0, 10},
ColorFunction -> Function[{x, y, z}, Hue[z]]]


or

f1 = Abs[Cos[t]] (Sin[x] + Cos[y]) + Sqrt[t]/Log[t]
tOpt = NMaximize[{f1, t > 2, t < 10}, t]
tOpt = tOpt[[2]][[1]][[2]]
Plot3D[tOpt, {x, 0, 10}, {y, 0, 10},
ColorFunction -> Function[{x, y, z}, Hue[z]]]


But for simple function it works

• Welcome to Mathematica StackExchange! How well do you already know Mathematica syntax? Do you know about Plot3D and NMaximize? Have you been able to write your function $f_1$ in Mathematica code? If yes, please include it in your question. Commented Dec 28, 2022 at 13:01
• I have included the attempt of solving. But i do not know how to correct using of NMaximize for my question. Commented Dec 28, 2022 at 13:26

## 2 Answers

• Replace Abs[Cos[t]] with Sqrt[Cos[t]*Cos[t] ], we can calculate  D[f1, t].

• Then we use ContourPlot3D to plot the equation D[f1, t] == 0 and D[f1, {t, 2}] < 0

Clear[f1];
f1 = Sqrt[Cos[t]*Cos[t]] (Sin[x] + Cos[y]) + Sqrt[t]/Log[t];
ContourPlot3D[
D[f1, t] == 0 // Evaluate, {x, 0, 10}, {y, 0, 10}, {t, 2, 10},
ColorFunction -> Function[{x, y, z}, Hue[z]],
RegionFunction -> Function[{x, y, t}, Evaluate[D[f1, {t, 2}] < 0]],
RegionBoundaryStyle -> None]


• We try to view the maximum of f1 by SliceContourPlot3D.
SliceContourPlot3D[
Sqrt[Cos[t]*Cos[t]] (Sin[x] + Cos[y]) +
Sqrt[t]/Log[t], {"BackPlanes", "CenterCutSphere"}, {x, 0, 10}, {y,
0, 10}, {t, 2, 10}, ColorFunction -> Hue]


*

sol = NMaximize[{Sqrt[Cos[t]*Cos[t]] (Sin[x] + Cos[y]) +
Sqrt[t]/Log[t], 0 <= x <= 10, 0 <= y <= 10, 2 <= t <= 20}, {x, y,
t}]
ContourPlot3D[
Sqrt[Cos[t]*Cos[t]] (Sin[x] + Cos[y]) + Sqrt[t]/Log[t] ==
sol[[1]], {x, 0, 10}, {y, 0, 10}, {t, 2, 10},
PlotLegends -> Automatic]


• I don't think this is what the OP is looking for. (S)he is looking for the arg max of $f_1$ (which – as stated in the question – cannot be found by $\partial_t f_1 = 0$). Commented Dec 28, 2022 at 13:54
• @Domen At lest the above method work for his simple case where f1 = t (Sin[x] + Cos[y]) + t^2; Commented Dec 28, 2022 at 13:56
• Domen, thanks, I try for my another large functions. cvgmt, yes, $\frac{{\partial {f_1}\left( {x,y,t} \right)}}{{\partial t}} = 0$ is the part of my attempt of maximum finding. Commented Dec 28, 2022 at 14:06

To find a global extrema via first derivatives, the function must be continuously differentiable. Because of $$|\cos(t)|$$, your function is not. You can also see this by plotting a function for some chosen $$x,y$$:

f1[x_, y_, t_] := Abs[Cos[t]] (Sin[x] + Cos[y]) + Sqrt[t]/Log[t];
Plot[f1[4, 9, t], {t, 2, 10}]


The maximum occurs at a cusp at $$t=3\pi/2$$. Now, to find the global maximum in Mathematica, you can use Maximize or NMaximize.

tOpt[x_?NumericQ, y_?NumericQ] := t /. Last@Maximize[{f1[x, y, t], 2 <= t <= 10}, t];
Plot3D[tOpt[x, y], {x, 0, 10}, {y, 0, 10}, ColorFunction -> "Rainbow",
PlotPoints -> 10, PerformanceGoal -> "Speed"]


However, using either of these two is quite slow, as finding the global maximum is a tricky problem. Looking at the $$f_1$$ at different $$x,y$$, we can observe that there are three distinct regions.

Plot[Evaluate@Catenate@Table[f1[x, y, t], {x, 0, 10, 2}, {y, 0, 10, 2}], {t, 2, 10}]


Therefore, we can use FindMaximum – which searches for local maximum and is thus faster – for each region separately. We can make this even faster by conjecturing from the graph – some of the more mathematically-savy users can perhaps prove this – that the maximum occurs at $$t_{opt} \in [2, 5\pi/2] \cup \{7\pi/2\}$$.

tOptFaster[x_, y_] := Module[{sett, max1, max2, max3},
max1 = FindMaximum[{f1[x, y, t], 2 <= t <= 3 Pi/2}, {t, 2}];
max2 = {f1[x, y, 3 Pi/2], {t -> 3 Pi/2}};
max3 = {f1[x, y, 5 Pi/2], {t -> 5 Pi/2}};
t /. Last@First@MaximalBy[{max1, max2, max3}, First]
]

(* Change to control the speed and quality of the plot *)
step = .1;
ListPlot3D[
Evaluate@Catenate@
Table[{x, y, tOptFaster[x, y]}, {x, 0, 10, step}, {y, 0, 10,
step}], ColorFunction -> "Rainbow", PlotRange -> All]