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

$\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$
    – Domen
    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$
    – Imyaf
    Dec 28, 2022 at 13:26

2 Answers 2

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

$\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$
    – Domen
    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$
    – cvgmt
    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$
    – Imyaf
    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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.