4
$\begingroup$

Consider:

i = 0.1;
While[
 i < 0.9,
 y[x_] :=
  y /. FindRoot[{u/(1 - u) (x + Log[y]) - 1 /. u -> i}, {y, 3}];
 Plot[y[x], {x, 0, 4}];
 i = i + 0.1]

I want to draw graphs for y[x] for different i's in one graph. Then based on the top answer, I write the following code for further progame:

Clear[f, y, i]

f[x_] := Quiet[y /. FindRoot[i (x + Log[y])/(1 - i) - 1, {y, 3}]]

output = {};

i = 0.1;
While[i < 0.9,
 AppendTo[output, 
  g := x /. Last[FindMaximum[-f[x]^(1/4) - 1/f[x], {x, 3}]];
  t = Table[{i, g}, {i, 0, 1, 0.1}];
  h = Table[{i, f[g]}, {i, 0, 1, 0.1}];
 i = i + 0.05]

ListLinePlot[{t,h}]

But I cannot plot h.

$\endgroup$
1
  • $\begingroup$ One-space indent? Please, no. $\endgroup$ Nov 15 '21 at 0:15
5
$\begingroup$
Clear[f, y, i]

f[x_] := Quiet[y /. FindRoot[i (x + Log[y])/(1 - i) - 1, {y, 3}]]

output = {};

i = 0.1;
While[i < 0.9,
  AppendTo[output, Table[{x, f[x]}, {x, 0, 4, 0.1}]];
  i = i + 0.1]

ListLinePlot[output,
 PlotLegends -> Map["i = " <> ToString[#] &, Range[8]/10.]]

enter image description here

With PlotRange -> All to include the first curve in the plot.

ListLinePlot[output,
 PlotLegends -> Map["i = " <> ToString[#] &, Range[8]/10.],
 PlotRange -> All]

Or use log plot

ListLogPlot[output,
 PlotLegends -> Map["i = " <> ToString[#] &, Range[8]/10.],
 Joined -> True]

enter image description here

Also, super-cautious approach, discarding any points that the root finder had trouble with.

Clear[f, y, i]

f[x_] := Quiet[
  ans = y /. FindRoot[i (x + Log[y])/(1 - i) - 1, {y, 3},
     MaxIterations -> 1000];
  If[Length[$MessageList] > 0, "discard", ans]]

output = {};

i = 0.1;
While[i < 0.9,
  AppendTo[output, Table[{x, f[x]}, {x, 0, 4, 0.1}]];
  i = i + 0.1]

ListLogPlot[output /. {_, _String} -> Nothing,
 PlotLegends -> Map["i = " <> ToString[#] &, Range[8]/10.]]

enter image description here

Additional question

Show[
 ListLinePlot[(i = #;
     Cases[Table[{x, -f[x]^(1/4) - 1/f[x]}, {x, -3, 6, 0.01}],
      {_, _Real}]) & /@ (Range[8]/10.),
  PlotRange -> {{-3, 6}, {-14, 0}}],
 ListPlot[(i = #;
     MaximalBy[
      Cases[Table[{x, -f[x]^(1/4) - 1/f[x]}, {x, -3, 6, 0.01}],
       {_, _Real}], Last]) & /@ (Range[8]/10.),
  PlotRange -> {{-3, 6}, {-14, 0}}, PlotStyle -> Black]]

enter image description here

{i = #,
   MaximalBy[
     Cases[Table[{x, -f[x]^(1/4) - 1/f[x]}, {x, -3, 6, 0.01}],
      {_, _Real}], Last][[1, 2]]} & /@ (Range[8]/10.)
{{0.1, -2.16679}, {0.2, -1.64939}, {0.3, -1.64939}, {0.4, -1.64939},
 {0.5, -1.64939}, {0.6, -1.64939}, {0.7, -1.64938}, {0.8, -1.64939}}

The maximum z value is basically constant.

$\endgroup$
2
  • $\begingroup$ thank you very much!! If you don't mind, can I ask another question? I want to find the maximum for this function: -f[x]^(1/4) - 1/f[x] at each i. i.e., for a given i, z=x/. Last[FindMaximum[ -f[x]^(1/4) - 1/f[x],{x,3}]]. And I want to draw a graph of z over i. $\endgroup$
    – calista
    Nov 16 '21 at 11:37
  • $\begingroup$ FindMaximum doesn't like that much! Using Table again ... (see edit) $\endgroup$ Nov 16 '21 at 13:59
3
$\begingroup$

One way might be

root[x_?NumericQ, i_] := y /. First@FindRoot[i/(1 - i) (x + Log[y]) - 1, {y, 3}]
Last@Reap@Do[
   Sow@Plot[root[x, i], {x, 0, 4}], {i, 0.1, 0.9, 0.1}
   ]

Mathematica graphics

$\endgroup$
3
$\begingroup$

The roots can be found directly with Solve.

sol = Simplify[
  SolveValues[{u/(1 - u) (x + Log[y]) - 1 == 0, 0 < u < 1}, y, Reals], 
  0 < u < 1]

(* {E^(-1 + 1/u - x)} *)

Plot[
 Evaluate@
  Table[Tooltip[sol[[1]], u], {u, 0.1, 0.8, 0.1}],
 {x, 0, 4},
 AxesLabel -> (Style[#, 12, Bold] & /@ {x, y}),
 PlotLegends ->
  Placed[
   LineLegend[Range[0.1, 0.8, 0.1],
    LegendLabel -> Style[u, 12, Bold]],
   {0.9, 0.57}],
 PlotLabel ->
  StringForm["``", u/(1 - u) (x + Log[y]) - 1 == 0]]

enter image description here

The line for u == 0.1 is off the top of the Plot. To show it, all of the other lines would be drawn on top of each other. Consequently, use "Log" scaling.

Plot[
 Evaluate@
  Table[Tooltip[sol[[1]], u], {u, 0.1, 0.8, 0.1}],
 {x, 0, 4},
 PlotRange -> All,
 AxesLabel -> (Style[#, 12, Bold] & /@ {x, y}),
 PlotLegends ->
  LineLegend[Range[0.1, 0.8, 0.1],
   LegendLabel -> Style[u, 12, Bold]],
 PlotLabel ->
  StringForm["``", u/(1 - u) (x + Log[y]) - 1 == 0],
 ScalingFunctions -> "Log"]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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