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

Question

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

Answer 1

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

Answer 2

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]