Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

There are no issues trying to find the intersection points of two defined curves.

    f[x_] := 2 (x - 1) (x - 1.5) (x - .5) (x + .5) (x + 1) (x + 1.5);
    g[x_] := 0.4 x - 0.4;
    Solve[f[x] == g[x], x]
    (*{{x -> -1.39849}, {x -> -1.20949}, {x -> -0.331841}, {x -> 
      0.426865}, {x -> 1.}, {x -> 1.51295}}*)
    Manipulate[Plot[Evaluate[{f[x], g[x]}], {x, -1.5, 1.52}, 
               Epilog -> {Red, PointSize[Large], 
               Point[{#, f[#]} & /@ (x /. 
               Solve[f[x] == g[x], x])]}], {a, -0.8, .5, .2}]

enter image description here

When I try to perform the same but this time with an interpolation function I run into problems.

points = Table[{x, f[x]}, {x, -1.5, 1.5, .25}];
if = Interpolation[points];

I can obtain the first intersection by using the following.

Neither NSolve nor Solve will work with interpolation function.

With Solve this will happen

Solve[if[x] == g[x], x]

Solve::inex: Solve was unable to solve the system with inexact coefficients or the system obtained by direct rationalization of inexact numbers present in the system. Since many of the methods used by Solve require exact input, providing Solve with an exact version of the system may help. >>

With NSolve, you get a similar error.

NSolve[if[x] == g[x], x, Reals]

(NSolve[InterpolatingFunction[{{-1.5,1.5}},<>][x]==-0.4+0.4 x,x,Reals])

FindRoot[if[x] == g[x], {x, -1.5}]
(*{x -> -1.36794}*)

Which makes this question different from marking points of intersections between two curves as the problem is specific when using InterpolationFunction

What is the best way to find all intersection points between the range (-1.5 and 1.5)?

share|improve this question
    
Related: 23609, 35107 –  Michael E2 Feb 14 at 20:50
    
I've reopened the question, but in future, please ping me in the comments (I'll receive the ping if I've edited/commented/closed) or in chat, as otherwise I won't get your message. I just happened to look at the revision summary as I was browsing :) –  rm -rf Feb 15 at 5:30

5 Answers 5

up vote 17 down vote accepted

[I gave a similar response some time ago either in StackOverflow or MSE but now I cannot find it.]

One way is to track the solution to the ODE that runs over the difference if[x]-g[x]. Use WhenEvent to record axis crossings. This will find all zeros that do not have multiplicity (that is, that cross transversally). Should also find any that are of odd multiplicity since they still cross the axis, albeit at slope of zero.

Reap[
  odsoln = NDSolve[{y'[x] == if'[x] - g'[x], 
      y[-1.5] == if[-1.5] - g[-1.5], WhenEvent[y[x] == 0, Sow[x]]}, 
     y[x], {x, -1.5, 1.5}];][[2, 1]]

(* Out[21]= {-1.36793657661, -1.19575651253, -0.330396218898, \
0.425433482282, 0.999999923787} *)

Plot[y[x] /. odsoln[[1]], {x, -1.5, 1.5}]

enter image description here

share|improve this answer
    
Nice .. Have to wonder why FindRoot doesn't have an option to find multiple roots since this is really all it would need to do.. –  george2079 Feb 14 at 20:59

Here is a method that works with your example :

First, one plots the two functions with a special mesh :

f[x_] := 2 (x - 1) (x - 1.5) (x - .5) (x + .5) (x + 1) (x + 1.5);
g[x_] := 0.4 x - 0.4;
points = Table[{x, f[x]}, {x, -1.5, 1.5, .25}];
if = Interpolation[points];

graphic = 
 Plot[Evaluate[{if[x], g[x]}], {x, -1.5, 1.52}, Mesh -> {{0.}}, 
  MeshFunctions -> {if[#] - g[#] &}, MeshStyle -> PointSize[Large]]  

enter image description here

Then one extracts the points from the graphic. There are duplicata that must be removed :

pointsList = 
 Cases[Normal[graphic], Point[x_] :> x, {1, Infinity}]  //
 Gather[#, Abs[#1[[1]] - #2[[1]]] < 0.0001 &] & //
 First /@ # &

{{0.425434, -0.230426}, {-1.19576, -0.877972}, {1., -0.000093329}, {-0.330396, -0.532158}, {-1.36794, -0.947173}, {1.51695, 0.206782}}

Be carefull with this method:
The documentation of MeshFunctions says that the MeshFunctions should normally be chosen to be continuous monotonic functions. This is not the case here.

share|improve this answer

I take it that the essential question is how to solve an equation in which a term involves an InterpolatingFunction. If it is merely to plot the points, then I would use andre's method. Otherwise, I would use an approach like Daniel Lichtblau's with a small modification. The rest of this is essentially an extended comment to Daniel's answer and george2079's comment to it.

NDSolve is particularly well-suited to this task. The reasons are manifold. First, the process of integration runs over the whole interval and is likely to discover all the roots where a sign change occurs. Second, root-finding algorithms are invoked when an event in WhenEvent is detected. Further the initial condition for an event will be close to the root and the root-finding algorithms will converge relatively quickly, so quickly that in the OP's example the time it took NDSolve to find all of the roots was about the same as using FindRoot on each of them. So NDSolve is being used to track the function and invoke Finally, if the function is highly oscillatory, NDSolve will adapt its step size so that zero-crossings are not (likely to be) missed.

You get more accurate results if the equation to be solved is passed to WhenEvent instead of y[x] == 0. It seems an important principle, even if the interpolating function is only approximate. The symbol y[x] represents another layer of approximation; it seems clearer to use the actual equation whose solution is desired. It takes slightly less time if you ask that no solution be returned. In the example below I added an oscillatory component.

With[{eq = if[x] - g[x] + Sin[200 x]/10},
 roots = Reap[
    NDSolve[{y'[x] == D[eq, x], y[0] == (eq /. x -> 0), 
       WhenEvent[eq == 0, Sow[x]]},
      {}, {x, -1.5, 1.5}];][[2, 1]]
 ]
(*
  {-0.304168, -0.310282, -0.329946, -0.349218, -0.355714, -1.16778, 
   -1.17454, -1.19405, -1.21169, -1.22167, -1.34002, -1.34738, -1.3668, 
   -1.38682, -1.391, 0.410548, 0.423902, 0.43804, 0.991196, 1.00719, 1.01613}
*)

Plot[if[x] - g[x] + Sin[200 x]/10, {t, -1.5, 1.5}, PlotPoints -> 250, 
 Mesh -> {roots}, MeshFunctions -> {# &}, 
 MeshStyle -> {PointSize[Medium], Red}]

Mathematica graphics

Using the actual equation instead of y[x] produces more accurate results:

With[{eq = if[x] - g[x] + Sin[200 x]/10},
 roots2 = Reap[
   NDSolve[{y'[x] == D[eq, x], y[0] == (eq /. x-> 0), 
      WhenEvent[y[x] == 0, Sow[x]]},
     {}, {x, -1.5, 1.5}];][[2, 1]]
 ];

Through[{Max, Mean, Min}[Abs[if[#] - g[#] + Sin[200 #]/10 & /@ Sort@roots]]]
Through[{Max, Mean, Min}[Abs[if[#] - g[#] + Sin[200 #]/10 & /@ Sort@roots2]]]
(*
  {2.55121*10^-10, 2.31578*10^-11, 9.71445*10^-17}
  {3.15835*10^-7,  1.6696*10^-7,   7.10046*10^-8}
*)
share|improve this answer

Another variation.. Here I'm using Plot's automatic incrementation to trace out a sufficiently smooth set of points, then feeding zero crossings as initial points into FindRoot..

  x /. FindRoot[if[x] - g[x], {x, #[[1, 1]], #[[2, 1]]}] & /@ 
           Select[ Partition[
                 Sort@Last@Last@Reap[
                   Plot[if[x] - g[x], {x, -1.5, 1.5},
                        EvaluationMonitor :> Sow[{x, if[x] - g[x]}]]],
                              2,1] ,
                             #[[2, 2]] #[[1, 2]] <= 0 & ]

{-1.36794, -1.19576, -0.330396, 0.425433, 1.}

share|improve this answer
    
The RootSearch package <library.wolfram.com/infocenter/MathSource/4482/>; by Ted Ersek returns all the roots over a specified range as a list of replacement rules This package .A RootsInRange function was presented in "Finding Roots in an Interval" in The Mathematica Journal 7(2), 1998: should be sufficient: –  TheDoctor Feb 19 at 7:24

The RootSearch package http://library.wolfram.com/infocenter/MathSource/4482/ by Ted Ersek returns all the roots over a specified range as a list of replacement rules.

A RootsInRange function was presented in "Finding Roots in an Interval" in The Mathematica Journal 7(2), 1998 (http://www.mathematica-journal.com/issue/v7i2/ updated code below):

f[x_] := 2 (x - 1) (x - 1.5) (x - .5) (x + .5) (x + 1) (x + 1.5);
g[x_] := 0.4 x - 0.4;
points = Table[{x, f[x]}, {x, -1.5, 1.5, .25}];
if = Interpolation[points];

RootsInRange[{f1_, f2_}, {t_, tmin_, tmax_}, opts___] := 
  Module[{p, r, pts, x, f = Function[t, Evaluate[f1 - f2]]}, 
    p = Plot[f[t], {t, tmin, tmax}, 
    Evaluate[Sequence @@ FilterRules[{opts}, Options@Plot]]]; 
    pts = Cases[First[p], Line[{x__}] -> x, Infinity]; 
    r = Abs[Subtract @@ Last@PlotRange[p]]; 
    pts = Map[First, 
      Select[Split[pts, 
        Sign[Last[#2]] == -Sign[Last[#1]] && 
          Abs[Last[#2] - Last[#1]] < r/2 &], Length[#1] == 2 &], {2}]; 
    pts = (FindRoot[f[t] == 0, {t, Sequence @@ ##}, 
    Evaluate[
      Sequence @@ FilterRules[{opts}, Options@FindRoot]]] &) /@ pts;
    Print[Plot[{f1, f2}, {t, tmin, tmax}, 
      Epilog -> {Green, AbsolutePointSize[4], 
      Point /@ ({t, f1} /. pts)}, 
    Evaluate[Sequence @@ FilterRules[{opts}, Options@Plot]]]]; pts]

RootsInRange[f1_ == f2_, {t_, tmin_, tmax_}, opts___] := 
  RootsInRange[{f1, f2}, {t, tmin, tmax}, opts]

For example

RootsInRange[if[x] == g[x], {x, -1.5, 1.5}]

RootsInRange[if[x] == g[x] - Sin[200 x]/10, {x, -1.5, 1.5}, PlotPoints -> 20]
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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