8
$\begingroup$

I'm currently stuck on a question for class that asks...

"Find a polynomial p[x] that you can use to calculate 6 ArcTan[x] to within an error of no more than 10^(-5) for all the x's with -(1/Sqrt[3]) <= x <= 1/Sqrt[3]."

I used a series expansion below.

Clear[x]; approx6arctan[x_] = Normal[Series[6Tan[x], {x, 0, 200}]]

However, this can only generate a function that's accurate only to the fourth decimal, no matter how much I expand the series (200 is already huge).

Any hints on how to generate a polynomial that's accurate to the fifth decimal? Thanks in advance.

Improve this question
$\endgroup$
3
  • 2
    $\begingroup$ You have typed Tan instead of ArcTan. $\endgroup$ Commented Aug 9, 2014 at 1:30
  • $\begingroup$ See also: Plot[{approx6arctan[x],ArcTan[x]},{x,-Pi,Pi}] $\endgroup$ Commented Aug 9, 2014 at 2:41
  • 3
    $\begingroup$ This link about Chebyshev polynomials might be useful. $\endgroup$ Commented Aug 9, 2014 at 22:21

4 Answers 4

Reset to default
14
$\begingroup$

From Weierstrass Approximation Theorem we know there is such a polynomial, moreover there are infinitely many polynomials satisfying given criterion. Therefore we would like to find those ones of the minimal order.

Since we are supposed to exploit series approximations we define a polynomial of n - th order approximating 6 ArcTan[x] for x such that (-(1/Sqrt[3]) <= x <= 1/Sqrt[3]) with the 10^(-5) accuracy. We can use a Taylor series of the given function:

poly[x_, n_Integer] /; n > 0 := Normal @ Series[ 6 ArcTan[x], { x, 0, n}]

Next we would like to minimize the "error" function like the following:

Abs[ poly[x, n] - 6 ArcTan[x]]

We could proceed further with symbolic functions however numeric ones can be much faster thus we can use NMaximize with the constraint -(1/Sqrt[3]) <= x <= 1/Sqrt[3]:

NMaximize[{ Abs[poly[x, n] - 6 ArcTan[x]], -(1/Sqrt[3]) <= x <= 1/Sqrt[3]}, x]

Finally we can exploit the new function in Mathematica 10 SelectFirst:

SelectFirst[ Table[{ n, First @ NMaximize[{ Abs[poly[x, n] - 6 ArcTan[x]], -(1/Sqrt[3]) <= x <= 1/Sqrt[3]}, x]}, {n, 4, 20}], Last[#] < 10^-5 &] 
{17, 7.12022*10^-6}

So the minimal order polynomial is 

poly[x, 17] 
6 x - 2 x^3 + (6 x^5)/5 - (6 x^7)/7 + (2 x^9)/3 - (6 x^11)/11 + (6 x^13)/13 - (2 x^15)/5 + (6 x^17)/17

much lower order than you expected.

Edit

We have exploited Taylor series solutions, now we can optimize approximations based on another tools Mathematica can offer.

Another answer introduced LeastSquarePolynomial providing quite a good approximation however in case of more general functions or if better approximations are needed that might appear to be too computationally complex since it involves symbolic integration.
Therefore alternative approach is welcome. We provide another solution based on a simple algebraic functionality InterpolatingPolynomial (see e.g. this answer Get polynomial interpolation formula for an idea how it works)

intpoly[x_, n_] := Collect[ InterpolatingPolynomial[ Table[ {x, 6 ArcTan[x]}, {x, -1/Sqrt[3], 1/Sqrt[3], 1/(n Sqrt[3])}], x], x, Simplify]

Now this polynomial also satisfies conditions:

intpoly[x, 5] // N // TraditionalForm

enter image description here

Now let's compare graphically various approximations:

Plot[{ 6 ArcTan[x] - intpoly[x, 5], 6 ArcTan[x] - poly, 6 ArcTan[x] - intpoly[x, 6]}, {x, -1/Sqrt[3], 1/Sqrt[3]}, Evaluated -> True, PlotStyle -> Thick, PlotLegends -> "Expressions"]

enter image description here

and its absolute values:

Plot[{ Abs[6 ArcTan[x] - intpoly[x, 5]], Abs[6 ArcTan[x] - poly], Abs[6 ArcTan[x] - intpoly[x, 6]]}, {x, -1/Sqrt[3], 1/Sqrt[3]}, Evaluated -> True, PlotStyle -> Thick, PlotLegends -> "Expressions"]

enter image description here

We can clearly see that

intpoly[x, 6] // N // TraditionalForm

enter image description here

wins that comparison with respect to accuracy while intpoly[x, 5] and poly are of the minimal order (9). However one could probably find even lower order polynomials satisfying the criterion.

Improve this answer
$\endgroup$
6
  • $\begingroup$ Thanks so much for your response, Artes. Really appreciate it. $\endgroup$ Commented Aug 9, 2014 at 1:19
  • $\begingroup$ @user19060 I'm glad I could help. If you have found what you were looking for you should accept the answer. It is recommended to register your account to benefit more from using this site $\endgroup$ Commented Aug 9, 2014 at 1:53
  • $\begingroup$ intpoly[x, 5] extremely close to the polynomial I found, awesome! Also you said "one could probably find even lower order polynomials satisfying the criterion", but I don't think that's possible. Linear least squares finds the polynomial that minimizes the max error of |f[x] - p[x]| if I remember correctly. $\endgroup$ Commented Aug 11, 2014 at 15:57
  • $\begingroup$ @ChipHurst I believe it depends on what kind of norm in the appropriate function space we consider. I can't definitely say it is possible however intpoly[x, 6] is a considerably better approximation than poly while the latter is better than intpoly[x, 5]. So I have to say that poly is a really good one. $\endgroup$ Commented Aug 11, 2014 at 16:21
  • $\begingroup$ @Artes, where is poly defined? Do you mean poly[x, 17]? $\endgroup$ Commented Aug 11, 2014 at 16:48
11
$\begingroup$

Taylor polynomials of order n aren't necessarily the nth degree polynomials that optimally approximate a function on a given interval.

We can use linear least squares to find the optimal polynomials for a fixed n.

inn[f_, g_, x_] := Integrate[f g, {x, -1/Sqrt[3], 1/Sqrt[3]}] LeastSquarePolynomial[f_, x_, n_] := With[{pows = x^Range[0, n]}, pows . LinearSolve[Outer[inn[#1, #2, x] &, pows, pows], inn[f, #, x] & /@ pows] ]

By inspection n == 9 is the first to achieve your desired error bound.

poly = LeastSquarePolynomial[6ArcTan[x], x, 9] (* 693/256(94140Sqrt[3]π - 512251)x - 1287/16(135345Sqrt[3]π - 736466)x^3 + 11583/640(6901020Sqrt[3]π - 37551197)x^5 - 590733/224(200130Sqrt[3]π - 1088987)x^7 + 18706545/1792(70868Sqrt[3]π - 385621)x^9 *) N[poly] (* 5.99999x - 1.99942x^3 + 1.18912x^5 - 0.771597x^7 + 0.351287x^9 *)

Here's the error:

NMaximize[{Abs[6ArcTan[x] - %], -1/Sqrt[3] <= x <= 1/Sqrt[3]}, x] (* {1.60527*10^-6, {x->-0.57735}} *)

and a plot

Plot[Abs[6ArcTan[x] - poly], {x, -1/Sqrt[3], 1/Sqrt[3]}]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ Considering this is a homework problem for a calculus class, I suspect "polynomial" here refers to a Taylor polynomial and not polynomials derived by non-calculus methods like least-squares. $\endgroup$ Commented Aug 9, 2014 at 4:05
9
$\begingroup$

We can find a 7th order polynomial that meets the requirement if we minimise the $\infty$-norm. For simplicity I construct an array of {x, 6 ArcTan[x]} over the required range and plug it into FindFit, no doubt there are better ways.

{a, b} = {-1, 1}/Sqrt[3]; data = Table[{x, 6 ArcTan[x]}, {x, a, b, (b - a)/1000.}]; n = 7; expr = Sum[c[i] x^i, {i, 1, n, 2}]; pars = Table[c[i], {i, 1, n, 2}]; fit = expr /. FindFit[data, expr, pars, x, NormFunction -> (Norm[#, Infinity] & )]

5.99985 x - 1.99354 x^3 + 1.12458 x^5 - 0.510485 x^7

The maximum error is:

NMaxValue[{fit - 6 ArcTan[x], a <= x <= b}, x]

9.53823*10^-6

Plot[fit - 6 ArcTan[x], {x, a, b}, GridLines -> {None, {-10^-5, 10^-5}}]

enter image description here

Improve this answer
$\endgroup$
1
$\begingroup$

There are plenty of answers to this question already, but allow me to suggest to take a look at PadeApproximant if you want to come up with a good approximation to ArcTan[x]:

Manipulate[ Column[{ Row[{"ArcTan[x] \[TildeTilde] ", approx = PadeApproximant[ArcTan[x], {x, 0, {m, n}}]}], Plot[Abs[(approx - ArcTan[x])/ArcTan[x]], {x, -1/Sqrt[3], 1/Sqrt[3]}, ImageSize -> Large, PlotLabel -> "Error"] }], {m, 1, 7, 1}, {n, 1, 7, 1} ]
Improve this answer
$\endgroup$
2
  • $\begingroup$ That generates a rational function and not a polynomial, tho. But Padé approximants certainly are nice. $\endgroup$ Commented Dec 22, 2016 at 13:16
  • $\begingroup$ Yes, that's why I posted this suggestion. I certainly wished I'd have learned about them much sooner than I actually did. $\endgroup$ Commented Dec 22, 2016 at 13:46

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.