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.

I have two lists with the interpolated functions

list1 = {InterpolatingFunction[{{a1, b1}},<>], InterpolatingFunction[{{a2, b2}},<>],
  InterpolatingFunction[{{a3, b3}},<>], InterpolatingFunction[{{a4, b4}},<>]}

which I will think as $\mbox{list1} = \{f_1(x),f_2(x),f_3(x),f_4(x)\}$, and

list2 = {InterpolatingFunction[{{c1, d1}},<>], InterpolatingFunction[{{c2, d2}},<>],
  InterpolatingFunction[{{c3, d3}},<>], InterpolatingFunction[{{c4, d4}},<>]}

which I will think as $\mbox{list2} = \{g_1(x),g_2(x),g_3(x),g_4(x)\}$.

What I need is to define $$ f(x) = \begin{cases} f_1(x) & a_1 < x < b_1 \\ f_2(x) & a_2 < x < b_2 \\ f_3(x) & a_3 < x < b_3 \\ f_4(x) & a_4 < x < b_4 \end{cases} \quad \mbox{and} \quad g(x) = \begin{cases} g_1(x) & c_1 < x < d_1 \\ g_2(x) & c_2 < x < d_2 \\ g_3(x) & c_3 < x < d_3 \\ g_4(x) & c_4 < x < d_4 \end{cases} $$ in order to find a root of the equation $$ f(x) - g(x) = 0 $$

using the code

FindRoot[{f[x] - g[x] == 0},{x,x0}]

where the intervals $(a_i,b_i)$, $(c_i,d_i)$ are are well ordered (i.e. $a_1 < b_1 < a_2 < b_2 < ... < b_4$), and $x_0 \in [\min(a_1,c_1),\max(b_4,d_4)]$.

Here is an example:

list1 = Interpolation /@ Table[{2 i + k, Tan[k]}, {i, 1, 3, 2}, {k, -(\[Pi]/2) + 0.1,
  \[Pi]/2 - 0.1, 0.1}];

list2 = Interpolation /@ {Table[{i, i (i + 1/2) (i - 4)}, {i, -2, 5, 0.1}], 
  Table[{i, 5 (i - 8)}, {i, 6, 9, 0.1}]};

x0 = RandomReal[{-2, \[Pi]/2 - 0.1 + 8}];

In this case, $\mbox{list1} = \{f_1(x),f_2(x),f_3(x)\}$ and $\mbox{list2} = \{g_1(x),g_2(x)\}$.

I don't mind if no solution can be found for some $x_0$; what I don't want is to obtain spurious solutions due to extrapolation, or other gimmicks MMA might be using to "glue" the interpolated functions. In this particular example, the root $x \sim 9.43$ would be spurious, since neither $f$ nor $g$ are defined there.

$\hskip1.5in$enter image description here

Thanks for your time.

EDIT

Using @b.gatessucks suggestion, if I define

f[x_] := Piecewise[{{list1[[1]][x], -(\[Pi]/2) + 0.1 < x < \[Pi]/2 - 0.1},
   {list1[[2]][x], -(\[Pi]/2) + 0.1 + 4 < x < \[Pi]/2 - 0.1 + 4}, 
   {list1[[3]][x], -(\[Pi]/2) + 0.1 + 8 < x < \[Pi]/2 - 0.1 + 8}}];

g[x_] := Piecewise[{{list2[[1]][x], -2 < x < 5}, {list2[[2]][x], 6 < x < 9}}];

then

sols = Union[x /. FindRoot[f[x] == g[x], {x, #}] & /@ 
   Table[i, {i, -2, \[Pi]/2 - 0.1 + 8, .1}], SameTest -> (Abs[#1 - #2] <= 10^-6 &)]

returns some spurious solution:

$\hskip1cm$enter image description here

Is there a way to automatically drop such solutions (for example generating the grid only where both f and g are defined)?

share|improve this question
3  
Can't you use Piecewise ? –  b.gatessucks Mar 6 '13 at 20:38
1  
@b.gatessucks It's a little more convoluted than that –  belisarius Mar 7 '13 at 4:38

2 Answers 2

up vote 3 down vote accepted

This glues together a list of InterpolatingFunction into a Piecewise that is Indeterminate outside the domains, the reason for this is that FindRoot aborts when it encounters that as a function value.

pieceTogether[list_] := Function[\[FormalT],
  Evaluate@Piecewise[
   Map[{#@\[FormalT], #["Domain"][[1, 1]] <= \[FormalT] <= #["Domain"][[1, 2]]} &,list],
   Indeterminate]];

It uses an undocumented(?) feature to extract the domain of the InterpolatingFunction, you could do it in other ways but I find this the most convenient:

(First@list1)["Domain"]
(* {{0.529204, 3.4292}} *)

It is used like:

(* Evaluate f[t] to see what it did *)
f = pieceTogether[list1];
g = pieceTogether[list2];

p = Plot[{f[t], g[t]}, {t, -2.5, 10}];
Manipulate[
   (* If FindRoot gives some error suppress it and return None *)
   root = Quiet@Check[x /. FindRoot[f[x] == g[x], {x, x0}], None];
   (* Red point at the root or black on axis *)
   {color, pt} = If[root =!= None, {Red, {root, f[root]}}, {Black, {x0, 0}}];
   Show[p, Epilog -> {PointSize[Large], color, Point[pt]}]
 ,{{x0, 1}, -2.5, 12}]

root search

share|improve this answer
    
This is fantastic! Thank you very much! –  Pragabhava Mar 6 '13 at 21:24

The following tries to find one root in each subinterval where both functions are defined:

list1 = Interpolation /@ Table[{2 i + k, Tan[k]}, {i, 1, 3, 2}, 
                                                  {k, -(\[Pi]/2) + 0.1, \[Pi]/2 - 0.1, 0.1}];

list2 = Interpolation /@ {Table[{i, i (i + 1/2) (i - 4)}, {i, -2, 5, 0.1}], 
                          Table[{i, 5 (i - 8)}, {i, 6, 9, 0.1}]};

Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
ClearAll[u];
f1 = Piecewise[{#[u], Less @@ Riffle[InterpolatingFunctionDomain[#][[1]], u]}&/@ list1, 100];
g1 = Piecewise[{#[u], Less @@ Riffle[InterpolatingFunctionDomain[#][[1]], u]}&/@ list2, 100];
i = (IntervalUnion @@ (Interval@ InterpolatingFunctionDomain[#][[1]] & /@ #)) &;
i1 = List @@ IntervalIntersection[i@list1, i@list2];
If[Chop@(f1 - g1 /. u -> x /. #) == 0., #, {}] & /@ 
   FindRoot[Evaluate[(f1 - g1 == 0) /. u -> x], #] & /@ ({x, Mean@#, Sequence @@ #} & /@ i1)

(*
 {{x -> 0.747098}, {{}}, {{}}}
 *)
share|improve this answer
    
This is great too! Now I need to modify it to find all roots in the subintervals. Thanks a lot! –  Pragabhava Mar 7 '13 at 1:48
1  
Is there an easy way to adapt it to problems of the form FindRoot[{h1[x,y] + f1[x]==0, h2[x,y] + g1[y] == 0},{{x,x0},{y,y0}}] Where h1 and h2 are continuous functions and f1, g1 are the Piecewise defined functions? I'm having lots of troubles trying. –  Pragabhava Mar 7 '13 at 4:21
    
@Pragabhava Not really sure ... perhaps another good question there –  belisarius Mar 7 '13 at 4:37

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.