Generating a polynomial that's accurate to within an error of no more than 1/10^5

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.

-
You have typed Tan instead of ArcTan. –  Kellen Myers Aug 9 '14 at 1:30
See also: Plot[{approx6arctan[x],ArcTan[x]},{x,-Pi,Pi}] –  Kellen Myers Aug 9 '14 at 2:41
This link about Chebyshev polynomials might be useful. –  Daniel Lichtblau Aug 9 '14 at 22:21

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


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"]


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"]


We can clearly see that

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


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.

-
Thanks so much for your response, Artes. Really appreciate it. –  user19060 Aug 9 '14 at 1:19
@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 –  Artes Aug 9 '14 at 1:53
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. –  Chip Hurst Aug 11 '14 at 15:57
@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. –  Artes Aug 11 '14 at 16:21
@Artes, where is poly defined? Do you mean poly[x, 17]? –  Chip Hurst Aug 11 '14 at 16:48

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]}]


-
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. –  Kellen Myers Aug 9 '14 at 4:05

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}}]


-