0
$\begingroup$

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 enter image description here

Improve this question
$\endgroup$
2
  • $\begingroup$ 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. $\endgroup$ Commented Dec 28, 2022 at 13:01
  • $\begingroup$ I have included the attempt of solving. But i do not know how to correct using of NMaximize for my question. $\endgroup$ Commented Dec 28, 2022 at 13:26

2 Answers 2

Reset to default
2
$\begingroup$

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

enter image description here

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

enter image description here

*

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]

enter image description here

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ 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$). $\endgroup$ Commented Dec 28, 2022 at 13:54
  • $\begingroup$ @Domen At lest the above method work for his simple case where f1 = t (Sin[x] + Cos[y]) + t^2; $\endgroup$ Commented Dec 28, 2022 at 13:56
  • $\begingroup$ 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. $\endgroup$ Commented Dec 28, 2022 at 14:06
1
$\begingroup$

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

Plot

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

Maximize

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

Plot

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]

Result

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.