Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

Say I have a function like this:

f[x_] := 4 x^4 - 9 x^3 - x^2 + 10;
Plot[f[x], {x, -1, 2}]

enter image description here

It's obvious that there's a tangent line with 2 points of tangency here:

enter image description here

The problem is, how can I find this line programmatically for any such curve given?


UPDATE: Sorry, I lied. My function is actually f[\[CurlyPhi]_] := 1.100955 \[CurlyPhi] (1 - \[CurlyPhi]) + \[CurlyPhi]/9.99968* Log[\[CurlyPhi]] + (1 - \[CurlyPhi]) Log[1 - \[CurlyPhi]], which, even with a "Rationalize" at the head, yields a error message as follows:

This system cannot be solved with the methods available to Reduce.

What can I do about this?

share|improve this question
up vote 11 down vote accepted

Introduction:

We are looking for two distinct values of $x$ for which a generic line and your function have 1) the same $y$ value (i.e. the line touches the curve) and 2) the same derivative (i.e. the line is tangent to the curve).

We can set up the following system of equations spelling out these conditions:

y[x_] := a x + b                      (* a generic line *)
f[x_] := 4 x^4 - 9 x^3 - x^2 + 10;    (* your function  *)

sol = List@ToRules@Reduce[
    {y[x1] == f[x1],
     y'[x1] == f'[x1],
     y[x2] == f[x2],
     y'[x2] == f'[x2],
     x2 != x1},
    {x1, x2}
  ]

solutions

Notice that Solve wouldn't work here, because there are no general solutions valid for all values of the parameters (indeed, Solve will return the empty set). Reduce will generate conditions valid for some values of the parameters $a$ and $b$, which is what we are looking for. Reduce returns equations as results, but I converted those to substitution rules for plotting.

Plot[
  {f[x], y[x] /. sol}, {x, -1, 2},
  Epilog -> {PointSize[0.015], Point[{{x1, f[x1]}, {x2, f[x2]}}] //. sol}
]

plot

A self-contained function:

We can package this in a function:

Clear[doubleTangent]
doubleTangent[f_, range_ /; VectorQ[range, NumericQ] && Dimensions[range] == {2}] :=
 Module[
  {x1, x2, a, b, y, sol},
  y[x_] := a x + b;
  sol = Solve[{
       f[x1] == y[x1], f[x2] == y[x2],
       f'[x1] == y'[x1], f'[x2] == y'[x2], x1 != x2},
     {x1, x2, a, b}, Reals
   ];
  Plot[
   {f[x], y[x] /. sol},
   Evaluate@Flatten@{x, range},
   PlotLegends -> {"function", "tangent"},
   Epilog -> {
     ReplaceRepeated[
      {
       PointSize[0.02],
       Tooltip[Point[{#, f[#]}], Round[{#, f[#]}, 0.01]] & /@ {x1, x2}
      },
      N@sol
     ],
     Inset[
      "a = " <> ToString[N[a /. First@sol]] <> "\nb = " <> ToString[N[b /. First@sol]],
      Scaled[{0.9, 0.9}], Alignment -> Left
     ]
   }
  ]
]

This function will return the same result found above, with annotations, when used as follows:

doubleTangent[4 #^4 - 9 #^3 - #^2 + 10 &, {-1, 2}]

old example with doubleTangent

Yet another case:

doubleTangent[3 #^4 - 12 #^2 + 5 # + 9 &, {-3, 3}]

another example

Using a numerical solver for non-polynomial functions:

Here is a version relying on a numerical solver (FindRoot) to solve the system of equations in those cases in which Solve or Reduce are unable to provide a solution. Of course, the method is quite a bit more brittle, and initial (even rough) estimates must be provided of the positions of the points of tangency. It is fiddly, but it works nonetheless :-)

Clear[doubleTangentNumeric]

doubleTangentNumeric[
  f_,
  range_ /; VectorQ[range, NumericQ] && Dimensions[range] == {2},
  initval_ /; VectorQ[initval, NumericQ] && Dimensions[initval] == {2}
  ] := Module[
  {x1, x2, a, b, y, sol},
  y[x_] := a x + b;
  (* This is the BIG CHANGE; using a numerical solver rather than Solve or Reduce *)
  sol = FindRoot[
     {f[x1] == y[x1],
      f[x2] == y[x2],
      f'[x1] == y'[x1],
      f'[x2] == y'[x2]},
     {{x1, initval[[1]]},
      {x2, initval[[2]]},
      {a, 1}, {b, 1}},
     WorkingPrecision -> 30, MaxIterations -> 1000
   ];
  Plot[
   {f[x], y[x] /. sol},
   Evaluate@Flatten@{x, range},
   PlotLegends -> {"function", "tangent"},

   (* Replaced First@sol with sol, since only one solution is returned by FindRoot *)
   Epilog -> {
     ReplaceRepeated[{PointSize[0.02], 
       Tooltip[Point[{#, f[#]}], Round[{#, f[#]}, 0.01]] & /@ {x1, x2}}, N@sol],
     Inset[
      "a = " <> ToString[N[a /. sol]] <> "\nb = " <> ToString[N[b /. sol]],
      Scaled[{0.8, 0.8}], Alignment -> Left]
     }
  ]
]

We can now try it on the function from your comment:

f = Log[1 - #1] (1 - #1) + (3125 Log[#1] #1)/31249 + (73666 (1 - #1) #1)/66911 &;

doubleTangentNumeric[f, {0, 1}, {0.1, 0.9}]

numerical results

share|improve this answer
    
Thanks! I tried your solution on my function Rationalize[1.100955 \[CurlyPhi] (1 - \[CurlyPhi]) + \[CurlyPhi]/9.99968* Log[\[CurlyPhi]] + (1 - \[CurlyPhi]) Log[1 - \[CurlyPhi]], 10^-10], but I got "This system cannot be solved with the methods available to Reduce". Any idea how can I get over this? – tslmy Mar 22 at 13:50
    
@tslmy That function will stretch the abilities of Solve (which is essentially a polynomial solver), and probably of Reduce as well. Let me see if I can modify the answer to use numerical root finding instead. – MarcoB Mar 22 at 15:59
    
@tslmy OK I've added a new version of doubleTangent to the bottom of my answer that uses a numerical solver and can deal with the function you mentioned. – MarcoB Mar 22 at 16:20

The tangent line at $x = a$ is given by $f(a)+f'(a)(x-a)$. So we can define:

tangent[a_, x_] := f[a] + f'[a] (x - a)
slope[a_] = Coefficient[tangent[a, x], x]
intercept[a_] = Coefficient[tangent[a, x], x, 0]

Then we want to find two distinct points $a$ and $b$ which have the same tangent line:

sln = Simplify@Solve[{slope[a] == slope[b], intercept[a] == intercept[b], b > a}, {a, b}]

{{a -> 1/16 (9 - 5 Sqrt[11]), b -> 1/16 (9 + 5 Sqrt[11])}}

There is one solution.

Plot[{f[x], tangent[a, x] /. sln}, {x, -1, 2}]

1

share|improve this answer
f2 = D[f[x], x]
x1 /. NSolve[{(f2 /. x -> x1) == (f2 /. 
       x -> x2), (f[x2] - f[x1])/(x2 - x1) == (f2 /. x -> x1)}, {x1, 
    x2}][[1]]
x2 /. NSolve[{(f2 /. x -> x1) == (f2 /. 
       x -> x2), (f[x2] - f[x1])/(x2 - x1) == (f2 /. x -> x1)}, {x1, 
    x2}][[1]]

which for your definition of f[x] results in x1=-0.473945 and x2=1.59895 PS: Note that

NSolve[{(f2 /. x -> x1) == (f2 /. 
     x -> x2), (f[x2] - f[x1])/(x2 - x1) == (f2 /. x -> x1)}, {x1, 
  x2}]

gives alternative coordinates:

{{x1 -> -0.473945, x2 -> 1.59895}, {x1 -> 1.59895, x2 -> -0.473945}}
share|improve this answer

An interesting alternative---and nice in that it is the shortest and almost the most automated so far---but one that I'm not entirely sure I understand, for reasons to be given along the way:

f[x_] := 4 x^4 - 9 x^3 - x^2 + 10;
expr = Series[f[x], {x, a, 1}] // Normal;
sols = DeleteDuplicates@SolveAlways[expr == (expr /. a -> b), x];
Plot[{f[x], expr /. #}, {x, -1, 2}] & /@ Thread[a -> (a /. sols)]

enter image description here

You can see that a couple of the solutions match the one we're looking for, most of the rest seem to match inflection points (not verified), and the last is the trivial solution a -> b.

Here is another example, taken from MarcoB's solution:

f[x_] = 3 x^4 - 12 x^2 + 5 x + 9;
expr = Series[f[x], {x, a, 1}] // Normal;
sols = DeleteDuplicates@SolveAlways[expr == (expr /. a -> b), x];
Plot[{f[x], expr /. #}, {x, -3, 3}] & /@ Thread[a -> (a /. sols)]

enter image description here

Again, it seems to work in that it finds the solution, but it finds others, too. I will think on this when I have the time.

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.