1
$\begingroup$

I have two functions $F(x,y)$ and $G(x,y)$ for $0<x\leq3$ and $-1\leq y \leq1$. Given a specific value of $y$, I want to find those values of $x$ for which we have $F=0$ and $G\neq \pm 1$.

For example, for $y=-1$, using NSolve, I get

y := -1;

F := -((3 Sin[3 x])/(2 x)) -  Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/ x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];

G := Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[ 3 x])/(2 x);

NSolve[F == 0 && 0 < x < 3 , x]
(*{{x -> 1.0472}, {x -> 1.12061}, {x -> 1.37163}, {x -> 1.88921}, {x ->  2.0944}}*)

NSolve[G == 1 && 0 < x < 3 , x]
(*{{x -> 0.510074}, {x -> 1.30826}, {x -> 1.5708}, {x -> 2.0944}, {x ->  2.44336}}*)

NSolve[G == -1 && 0 < x < 3 , x]
(* {{x -> 0.898222}, {x -> 1.0472}, {x -> 1.5708}, {x -> 1.86278}, {x ->  2.86912}} *)

hence, desired roots for $x$ are { {x -> 1.12061}, {x -> 1.37163}, {x -> 1.88921} }. Then, I can show these points together with my original functions $F$ and $G$, using this code

p1 := Plot[{F, G}, {x, 0, 3}, PlotRange -> {-1, 2}, PlotPoints -> 300, PlotLegends -> "Expressions", AxesLabel -> Automatic];

p2 = ListPlot[{  {1.1206084032394001`,   1.5 }   , {1.3716304436307527`,  1.5   } , {1.889214526133747`  ,   1.5  }     },  PlotMarkers -> {"\[Diamond]", Large}, PlotStyle -> Red]  ;

Show[{p1, p2}, PlotRange -> All]

as this picture

enter image description here

I have two questions:

Is there any way to get this picture without calculating the precise values of the roots (which we did byNSolve)? I mean something like using a conditional plot.

If the answer to the above question is YES, then, is it possible to use Manipulate/ Animate to get a continuous line of these red points when $y$ changes from $-1$ to $1$?

Ex. 1

F := -((3 Sin[3 x])/(2 x)) + Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/ x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];

G := Cos[3 x] + (2 Sin[3 x])/x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x];

With[{rat =  F /. {{f_ :> f}, {r : Sqrt[_] :> -r}} // Apply@Times // Expand // Simplify, F = F, G = G},  Manipulate[ Normal@Plot[{F, G}, {x, 4, 5}, PlotRange -> {-1, 1}, PlotPoints -> 500, PerformanceGoal -> "Speed", 
MeshFunctions -> {Function @@ {x, rat}}, MeshStyle -> Blue,  
Mesh -> {{0}}] /.   Point[p_] :> Point[p /. {x_Real, z_Real} :> {x, 0.5}] // 
DeleteCases[#,  Point[{x0_, _}] /; Abs[F /. x -> x0] > 0.1  ||  Abs[G^2 -1 /. x -> x0] < 0.01 ,  Infinity ] &, {y, 1, 3}]]
$\endgroup$
0

3 Answers 3

2
$\begingroup$
Normal@Plot[{F, G}, {x, 0, 3},
   PlotRange -> {-1, 2}, PlotPoints -> 300, 
   PlotLegends -> "Expressions", AxesLabel -> Automatic,
   MeshFunctions -> {Function[x, Re@F // Evaluate]} // Evaluate, 
   MeshStyle -> Red, Mesh -> {{0}}] /. 
 Point[p_] :> Point[p /. {x_Real, y_Real} :> {x, 1.5}]

One of the roots of F is not a simple root and F does not cross zero at it; hence the mesh functions miss it.

Update

Clear[x, y];
With[{rat = 
   F /. {{f_ :> f}, {r : Sqrt[_] :> -r}} // Apply@Times // Expand // 
    Simplify, F = F, G = G},
 Manipulate[
  Normal@Plot[{F, G}, {x, 0, 3},
      PlotRange -> {-1, 2}, PlotPoints -> 200, 
      PerformanceGoal -> "Speed",
      MeshFunctions -> {Function @@ {x, rat}}, MeshStyle -> Red, 
      Mesh -> {{0}}] /.
    Point[p_] :> Point[p /. {x_Real, z_Real} :> {x, 1.5}] // 
   DeleteCases[#, 
    Point[{x0_, _}] /; Abs[F /. x -> x0] > 0.1 || Abs[G^2 - 1 /. x -> x0] < 0.01,
    Infinity] &,
  {y, -5, 0}
  ]
 ] 

enter image description here

Not sure why PerformanceGoal -> "Speed" is needed to get a quality plot. (Some points are dropped if "Quality" is specified, even though no points are lost if evaluated outside Manipulate.)

$\endgroup$
13
  • 1
    $\begingroup$ To get all 5 points: rat = F /. {{f_ :> f}, {r : Sqrt[_] :> -r}} // Apply@Times // Expand // Simplify; Normal@Plot[{F, G}, {x, 0, 3}, PlotRange -> {-1, 2}, (*...*) MeshFunctions -> {Function[x, rat // Evaluate]} // Evaluate, Mesh -> {{0}}] /. Point[p_] :> Point[p /. {x_Real, y_Real} :> {x, 1.5}] // DeleteCases[#, Point[{x0_, _}] /; Abs[F /. x -> x0] > 0.1, Infinity] & $\endgroup$
    – Michael E2
    Commented Jan 25, 2022 at 1:14
  • 1
    $\begingroup$ @math2021 I got rid of $G=\pm1$, but for the trajectories, you would either have to calculate the zeros for all $y$ in a range or save them from each calculation & plot all the saved perhaps connected with Line[] (though if you scrub the slider back and forth quickly, you'll probably create a mess). Another issue is that around $y=-\pi$ there is only one root, so tracing three trajectories through that singularity poses a challenge. $\endgroup$
    – Michael E2
    Commented Jan 25, 2022 at 14:40
  • 1
    $\begingroup$ @math2021 The following calculates the trajectories of the zeros, somehow avoiding the singularity (lucky round-off error?). You asked not to numerically solve for the roots, but why not share the idea?: ics = Times @@ Subtract @@@ Flatten@NSolve[F == 0 && 0 < x < Pi && G^2 != 1 /. x -> x[y] /. y -> -2 Pi, x[-2 Pi]] == 0; x /. NDSolve[{Equal @@@ First@Solve[D[F /. x -> x[y], y] == 0, x'[y]], ics}, x, {y, -2 Pi, 0}] // ListLinePlot --- If it seems a feasible approach, we could go into it further. $\endgroup$
    – Michael E2
    Commented Jan 25, 2022 at 15:22
  • 1
    $\begingroup$ It’s almost always better to ask a new question, especially after several people have already answered the first question. (Also, what if person A gives the best answer to question 1 and a bad answer to Q2 while person B gives the best answer to Q2 and a bad answer to Q1? Our votes cannot really mark which is the best answer to both or to each, and the votes are supposed to help guide future visitors.) $\endgroup$
    – Michael E2
    Commented Jan 27, 2022 at 3:26
  • 1
    $\begingroup$ @math2021 The || Abs[G^2 - 1 /. x -> x0] < 0.01 (where || means Or) deletes any value of x0 where the value of G^2 at x equal to x0 is closer to 1 than 0.01. Add the same with H (or whatever) instead of G. (You can change the 0.01 if needed. Since the values generated by Plot are only roughly approximate, you have to pick a threshold.) $\endgroup$
    – Michael E2
    Commented Jan 27, 2022 at 16:34
3
$\begingroup$

Review

  • y=-1

Except NSolve or Reduce, none of the other three methods can include all the root! We can compare the four pictures.

f[x_, y_] = -((3 Sin[3 x])/(2 x)) - 
   Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
         x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];
g[x_, y_] = 
  Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
       3 x])/(2 x);
fig1 = Plot[f[x, -1], {x, 0, 3}, Exclusions -> {{f[x, -1] == 0}}, 
   ExclusionsStyle -> {Directive[Green, Thin], Directive[Red, Thick]},
    PlotRange -> {-2, 2}, 
   PlotLegends -> "Expressions"]; (* Method by Edmund *)
fig2 = Plot[f[x, -1], {x, 0, 3}, MeshFunctions -> {#2 &}, 
   Mesh -> {{0}}, MeshStyle -> Red, PlotRange -> {-2, 2}, 
   PlotLegends -> "Expressions"];
fig3 = With[{plot = Plot[{f[x, -1], 0}, {x, 0, 3}]}, 
   Show[plot, 
    Graphics[{Red, 
      Point[Graphics`Mesh`FindIntersections[plot, 
        Graphics`Mesh`AllPoints -> True]]}], PlotRange -> {-2, 2}]];
fig4 = Plot[f[x, -1], {x, 0, 3}, 
   Epilog -> {Red, 
     Point[{#, 0} & /@ 
       Evaluate@NSolveValues[{f[x, -1] == 0, 0 < x <= 3}, x]]}, 
   PlotRange -> {-2, 2}, PlotLegends -> "Expressions"];
GraphicsGrid[{{fig1, fig2}, {fig3, fig4}}]

enter image description here

  • y=1/2
f[x, y] /. {x -> π/3, y -> 1/2}
f[x, y] /. {x -> 2π/3, y -> 1/2}

0

enter image description here

Edit

Not so perfect.

Clear[F, G, fig];
F[x_, y_] = -((3 Sin[3 x])/(2 x)) - 
   Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
         x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];
G[x_, y_] = 
  Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
       3 x])/(2 x);
fig[y_] := 
  Module[{plotF, plotG, ptsF, ptsG}, 
   plotF = Plot[{F[x, y], 0}, {x, 0, 3}, PlotStyle -> {Orange, Gray}];
   ptsF = 
    Graphics`Mesh`FindIntersections[plotF, 
     Graphics`Mesh`AllPoints -> True];
   plotG = Plot[{G[x, y], 0}, {x, 0, 3}, PlotStyle -> {Cyan, Gray}];
   (*ptsG=Graphics`Mesh`FindIntersections[plotG,
   Graphics`Mesh`AllPoints->True];*)
   Show[plotG, plotF, 
    Graphics[{Red, Point[TranslationTransform[{0, 1.5}] /@ ptsF], 
      Green, Point[{{π/3, 0}, {2 π/3, 0}}]}]]];
Manipulate[fig[y], {y, -1, 1}, ControlPlacement -> Bottom]

enter image description here

Original

Clear[F, G];
F = -((3 Sin[3 x])/(2 x)) - 
   Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
         x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];

G = Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
       3 x])/(2 x);

Reduce[{F == 0, G == 1, 0 < x <= 3, -1 <= y <= 1}, {x, y}]
Reduce[{F == 0, G == -1, 0 < x <= 3, -1 <= y <= 1}, {x, y}]

x == (2 π)/3 && -1 <= y <= 1

x == π/3 && -1 <= y <= 1

It means that if we want to get F==0,G!=1,G!=-1, we just need to exclude x == (2 π)/3 and x == π/3 in F==0.

Clear[F, G, y];
F = -((3 Sin[3 x])/(2 x)) - 
   Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
         x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];
G = Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
       3 x])/(2 x);
y = -1;
Plot[{F, G}, {x, 0, 3}, 
 Epilog -> {Dashed, InfiniteLine[{π/3, 0}, {0, 1}], 
   InfiniteLine[{2 π/3, 0}, {0, 1}], 
   Text[Style["x=π/3", Red], {π/3, 5}, {-1, -1}], 
   Text[Style["x=2π/3", Red], {2 π/3, 5}, {-1, -1}]}]

enter image description here

$\endgroup$
2
  • $\begingroup$ Thank you very much. My question was to show those three red points (in the picture attached to the text) without calculating their precise values numerically; something like using the conditional plots (or any other ways that I am unaware of) for $F=0$ and $G\neq\pm1$. Since my problem is much more complicated in the general case, and, it is not easy to deal with them numerically; and, in the next step, manipulating those results for different values of $y$. @cvgmt $\endgroup$
    – math2021
    Commented Jan 24, 2022 at 15:13
  • $\begingroup$ Thank you for the update. $\endgroup$
    – math2021
    Commented Jan 24, 2022 at 17:01
1
$\begingroup$

You may use the Exclusions option of Plot.

First define your functions with SetDelayed to prevent variable scope issues.

Clear[f, g, x, y]
f[x_, y_] := -((3 Sin[3 x])/(2 x)) - 
  Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2]
g[x_, y_] := Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[3 x])/(2 x)

The Exclusions spec for y = -1 can be satisfied by

{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1}

Included in Plot

Plot[
 {f[x, -1], g[x, -1]}
 , {x, 0, 3}
 , Exclusions -> {{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1}}
 , ExclusionsStyle -> {Directive[Green, Thin], Directive[Red, Thick]}
 , PlotRange -> {-2, 2}
 , PlotLegends -> "Expressions"
 ]

Mathematica graphics

The red markers appear on the plot curves instead of floating. However, this is easy to Manipulate.

Manipulate[
 Plot[
  {f[x, my], g[x, my]}
  , {x, 0, 3}
  , Exclusions -> {{f[x, my] == 0, g[x, my] != 1 && g[x, my] != -1}}
  , ExclusionsStyle -> {Directive[Green, Thin], Directive[Red, Thick]}
  , PlotRange -> {-2, 2}
  , PlotLegends -> {Inactive[f][x, my], Inactive[g][x, my]}
  ]
 , {{my, -1, "y"}, -1, 1}
 ]

enter image description here

Note that the Exclusions spec can be used to simplify solving the x values if you want to go the Epilog route with InfiniteLine.

xvalues = NSolveValues[{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1 && 0 < x < 3}, x]
{1.12061, 1.37163, 1.88921}

Then

Plot[
 {f[x, -1], g[x, -1]}
 , {x, 0, 3}
 , Exclusions -> {{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1}}
 , ExclusionsStyle -> None
 , PlotRange -> {-2, 2}
 , PlotLegends -> "Expressions"
 , Epilog -> {Red, Dashed, InfiniteLine[{#, 0}, {0, 1}] & /@ xvalues}
 ]

Mathematica graphics

Hope this helps.

$\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.