2
$\begingroup$

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)?

$\endgroup$
2
  • 3
    $\begingroup$ Can't you use Piecewise ? $\endgroup$ Commented Mar 6, 2013 at 20:38
  • 2
    $\begingroup$ @b.gatessucks It's a little more convoluted than that $\endgroup$ Commented Mar 7, 2013 at 4:38

2 Answers 2

3
$\begingroup$

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

$\endgroup$
1
  • $\begingroup$ This is fantastic! Thank you very much! $\endgroup$
    – Pragabhava
    Commented Mar 6, 2013 at 21:24
1
$\begingroup$

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}, {{}}, {{}}}
 *)
$\endgroup$
3
  • $\begingroup$ This is great too! Now I need to modify it to find all roots in the subintervals. Thanks a lot! $\endgroup$
    – Pragabhava
    Commented Mar 7, 2013 at 1:48
  • 1
    $\begingroup$ 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. $\endgroup$
    – Pragabhava
    Commented Mar 7, 2013 at 4:21
  • $\begingroup$ @Pragabhava Not really sure ... perhaps another good question there $\endgroup$ Commented Mar 7, 2013 at 4:37

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.