5
$\begingroup$

I have this data set in Mathematica:

data = {{1980, 4716.71636}, {1981, 4530.36984}, {1982, 4301.97069}, {1983, 4335.91656}, {1984, 4468.26205}, {1985, 4484.33818}, {1986, 4487.85587}, {1987, 4680.83405}, {1988, 4885.5905}, {1989, 4948.02116}, {1990, 5121.17944}, {1991,  5071.56391}, {1992, 5174.6706}, {1993, 5281.38661}, {1994, 5375.0338}, {1995, 5436.69799}, {1996, 5625.04188}, {1997, 5701.92092}, {1998, 5749.89306}, {1999, 5829.51995}, {2000, 5997.29891}, {2001, 5899.85548}, {2002, 5942.42141}, {2003, 5991.19093}, {2004, 6105.44411}, {2005, 6130.55242}, {2006, 6050.3846}, {2007, 6127.88822}, {2008, 5928.25633},{2009,5493.54791}, {2010, 5700.10834}, {2011, 5572.58478}, {2012, 5371.77717}, {2013, 5522.90837}, {2014, 5572.10631}, {2015, 5422.96568}, {2016, 5306.66246}, {2017, 5270.74853}, {2018, 5416.27788}}

But I do not know how to code to curve fit it in the program. I have read multiple tutorials and watched videos on curve fitting polynomial data, but it is either about creating the dataset from an already established equation, or the instructions just flat out confused me. I have it curve fitted on Excel with a nasty equation that starts with an $x^6$ and numbers with awful decimals. The goal is to get a cleaner equation; how can I do this?

I have the data graphed as such:

Graph

$\endgroup$
  • 2
    $\begingroup$ A Chebyshev basis gives better coefficients. $\endgroup$ – Michael E2 Nov 26 '20 at 23:09
9
$\begingroup$

The goal is to get a cleaner equation how can I do this?

You can use (the experimental) FindFormula.

Here is an example:

dsFormulas = FindFormula[N@data, x, 5, All, SpecificityGoal -> 1, RandomSeeding -> 23];
dsFormulas = dsFormulas[SortBy[#Complexity &]]

enter image description here

Select a "cleaner" formula:

formula1 = Keys[Normal[dsFormulas]][[1]]

(* 5325.93 + 731.662 Cos[19. x] *)

Plot the formula together with the data:

ListPlot[{data, {#, formula1 /. x -> #} & /@ data[[All, 1]]}, 
 Joined -> {False, True}, PlotLegends -> {"Data", "Found formula"}, 
 AspectRatio -> 1/3, PlotTheme -> "Detailed", ImageSize -> Large]

enter image description here

$\endgroup$
14
$\begingroup$

EDIT:

If you just want a cleaner function, then stick with the excellent answers from @AntonAntonov and @MichaelE2. As they have shown, curve fitting can be done quite easily for your data in Mathematica, but it's my opinion that it's either the wrong tool for the job, or at least the results are more easily misinterpreted (unless you have a compelling reason to use a function that you haven't expressed here). Also, I stole the plot styling from @AntonAntonov's answer and forgot to give them credit.

ORIGINAL:

I would argue that data smoothing would be better here than curve fitting. Generally, the point of curve fitting is to either extract fitting parameters or to be able to extrapolate (a little ways) past the edge of the data. To do that, you need to have the model (or a small set of candidate models) first.

By modelling with a polynomial of any kind, you're essentially predicting that the emissions will go to $\pm \infty$ at some point in the future and were $\pm \infty$ in the past. By using a cosine model, you're predicting a constant oscillation in the emissions. Either way, the fitting constants/equations are almost certainly meaningless and there is probably no predictive power in choosing a random model. I would strongly caution against using any fitting constants returned for any of these curves unless you have other reasons to believe the model is correct.

With data smoothing, you're simply smoothing out sudden jumps in the data to allow the eye to more clearly follow a long-term trend. You can also do things like filter the data to remove long-period oscillations instead of short ones if you know that they are caused by some outside force.

There are various kinds of filters already available in Mathematica, though you can of course implement any kind of filter you like). I chose a Gaussian filter with a radius of 3 here (so that data over a 7 year period is considered), though other common options might be LowpassFilter, MovingAverage, or MeanFilter.

ListPlot[{
  data,
  {data[[All, 1]], GaussianFilter[data[[All, 2]], 3]}\[Transpose]
  },
 AspectRatio -> 1/3,
 Joined -> {False, True},
 PlotLegends -> {"Data", "7-Year Trend"},
 PlotTheme -> "Detailed"
]

Data with Gaussian filter.

$\endgroup$
  • 5
    $\begingroup$ @AntonAntonov. I disagree. It is common for posters to pose x/y questions (for those unfamiliar, requesting help on "x" when the actual problem is "y"). This post is a plausible candidate. Inferring and responding to the "y" is not considered off-topic. $\endgroup$ – Daniel Lichtblau Nov 27 '20 at 15:43
  • 1
    $\begingroup$ @DanielLichtblau I agree with your big picture perspective. My previous comment also comes from a "newcomer to WL" perspective. 1) A Newcomer wants to get a simple, concise expression for some data using WL. 2) An answer tells newcomer to use filtering, because WL has lots of filtering capabilities, and because of some methodological reasons. 3) Newcomer thinks WL cannot do fitting to data in a simple, automatic way and that is why the Newcomer is given a methodology answer that provides alternatives that are not of interest. 4) That impression of WL is wrong. $\endgroup$ – Anton Antonov Nov 27 '20 at 16:30
  • 1
    $\begingroup$ @DanielLichtblau I realize that I both exaggerate and oversimplify in my previous comment. I do think this answer is good to have, but only in conjunction with an answer that provides an easy way to find a fitting expression. (Which was requested by OP.) $\endgroup$ – Anton Antonov Nov 27 '20 at 16:35
  • 3
    $\begingroup$ @AntonAntonov I am certainly biased about this topic because I think that one of the best things about this forum is that challenges or alternatives to the OP's stated objectives can obtained from subject matter experts. In other words, it's not just about doing just what the OP asks for. I think this is especially true for statistics problems where the objective and potential consequences are at least as important as getting some function to execute properly. $\endgroup$ – JimB Nov 27 '20 at 17:05
  • 2
    $\begingroup$ @AntonAntonov I agree that there should also be a direct answer to the question asked. I made my post after your answer had already been accepted which is why I didn't provide one of my own, but I should have referenced the other answers and I've added some text to try to address that issue. If it doesn't properly clear up the issues you raised, feel free to edit it directly or else suggest some fixes. $\endgroup$ – MassDefect Nov 27 '20 at 19:46
7
$\begingroup$

The choice of basis makes a difference. You don't need a Chebyshev basis (see my comment), but a power basis $\{\,(x-c)^k\,\}_{k=0}^n$ centered at a number $c$ in the domain of the data will behave better than one centered far outside it, such as the standard power basis $\{\,x^k\,\}_{k=0}^n$. That's why the OP's polynomial looks so horrible.

Two alternatives are to center at beginning or in middle of the data:

domain = MinMax@data[[All,1]];
basis = (x - First@domain)^Range[0, 6];
basis = (x - Mean@domain)^Range[0, 6];

Here is the result using the first basis:

basis = (x - First@domain)^Range[0, 6];
lmf = LinearModelFit[N@data, basis, {x}];
lmf[x]
Plot[
 lmf[x], {x, Min@domain, Max@domain},
 Prolog -> {Point@data},
 Frame -> True, GridLines -> Automatic
 ]
(*
  4663.63 - 208.806 (-1980 + x) + 50.4679 (-1980 + x)^2 - 
   3.9543 (-1980 + x)^3 + 0.167273 (-1980 + x)^4 - 
   0.00378372 (-1980 + x)^5 + 0.0000344867 (-1980 + x)^6
*)

enter image description here

A nicer presentation of the polynomial may be achieved in terms of the increment from the beginning of the data:

lmf[First@domain + Δx]
(*
  4663.63 - 208.806 Δx + 50.4679 Δx^2 - 3.9543 Δx^3 + 
   0.167273 Δx^4 - 0.00378372 Δx^5 + 0.0000344867 Δx^6
*)

One purpose in fitting is to estimate parameters of a model of a phenomenon from experimental data. That doesn't seem to have any applicability here, which may be what prompted @MassDefect to suggest an alternative approach.

By the way, I think the OP's original fit was done correctly.

$\endgroup$
  • 1
    $\begingroup$ Thanks, @Anton. $\endgroup$ – Michael E2 Nov 27 '20 at 17:24
  • $\begingroup$ Why is the cantered polynomial better? Is it just because it avoids numerical error due to large powers of the abscissae? Also, makes the coefficients have values of order 1 (need to think what the numerical range would be). $\endgroup$ – Hugh Nov 27 '20 at 23:06
  • $\begingroup$ @Hugh Yes, it's a numerical issue and it also makes the coefficients smaller. Any polynomial basis yields the same polynomial function if computed exactly. If the terms of the function are large and the value low, then there must be corresponding round-off error. The degree-6 term in OP's polynomial and mine have the same coefficient. At x = Last@domain, they are 2 * 10^15 and 10^5 resp. (due to x^6 vs. Δx^6). Something has to cancel out for the function value to be around 5500. If you plot the OP's polynomial (change First@domain to 0), you'll see the round-off error is ~0.2%. $\endgroup$ – Michael E2 Nov 28 '20 at 0:28
  • $\begingroup$ Cool: The 0.2% is almost exactly the result of this: basis = (x - 0)^Range[0, 6]; lmf = LinearModelFit[N@data, basis, {x}]; Max@Abs[List @@ lmf[x] /. x -> Last@domain] $MachineEpsilon/5000 $\endgroup$ – Michael E2 Nov 28 '20 at 0:29

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.