Is there a tool to graph a function and have it compute its actual formula?

Question

Is there a tool to graph a function and have it compute its actual formula?

Thank you for your time beforehand.

As the question implies, I want to identify the actual function, not the type, given a graph, for example the following

Random curve:

Is there such a tool that accepts a freely drawn graph and returns the actual function?

Thank you sincerely!

πρόσεχε · Accepted Answer · 2022-03-18T17:22:21.620

In Wolfram Mathematica 13.0, after defining the following function:

ExtractData[source_, color_, x0_, y0_, Δx_, Δy_] :=
Module[{col, data, dist, image, max, pos},
     image = Import[source];
     col = DominantColors[image, ColorCoverage -&gt; .001];
     dist = ColorDistance[col, color];
     pos = Position[dist, Min[dist]][[1, 1]];

     data = Sort[PixelValuePositions[image, col[[pos]], .01]];
     data = Transpose[data] - First[data];

     max = {Max[data[[1]]], Max[data[[2]]]};
     Transpose[{x0, y0} + data {Δx, Δy} / max]

    ];

just write:

data = ExtractData["https://i.postimg.cc/hPy7F3bg/cwJqf.png", Black, 0.9, 2.0, 6.7, 3.0];
fdata = FindFormula[data, x]
ListPlot[{data, Table[{x, fdata}, {x, 0.9, 7.6, .001}]}, 
         AxesLabel -> {x, y}, 
         AxesOrigin -> {0, 0},
         GridLines -> Automatic,
         PlotRange -> {{0, 7.6}, {0, 5.0}},
         PlotStyle -> {Black, Red}]

to obtain:

-18.8816 + 58.3367 x - 67.3671 x^2 + 44.3662 x^3 - 18.1375 x^4 + 4.76048 x^5 - 0.802839 x^6 + 0.084062 x^7 - 0.00497126 x^8 + 0.000126869 x^9

which is "the best function" (at least according to Mathematica algorithms) that approximates the points of the approximate starting graph (in black the start graph, almost completely superimposed by the red end graph).

The power of FindFormula is that it almost instantly manages to identify the type of function that best approximates the experimental data among a multitude (obtainable by sum, product, composition, inversion of basic functions, i.e. polynomials, trigonometric, exponential functions). In fact, having decided to approximate the data with a ninth degree polynomial, it's sufficient to apply the least squares method:

{xi, yi} = Transpose[data];
NMinimize[Total[(yi - (a + b xi + c xi^2 + d xi^3 + e xi^4 + 
                 f xi^5 + g xi^6 + h xi^7 + i xi^8 + j xi^9))^2], 
          {a, b, c, d, e, f, g, h, i, j}]

by which the coefficients are quickly calculated:

{0.254024, {a -> -18.9847, b -> 58.6824, c -> -67.8439, d -> 44.7225, e -> -18.2975, f -> 4.80554, g -> -0.810858, h -> 0.0849365, i -> -0.00502458, j -> 0.000128261}}

which are essentially the same as those obtained automatically.

Of course, no one forbids to settle for a polynomial with a lesser degree, essentially this depends on the circumstances in which one operates. Anyway, by adding this other simple code:

frames = Table[coeff = Table[ToExpression[StringJoin["c", ToString[i]]], {i, 0, n}];
               fdata = Total[coeff Table[x^i, {i, 0, n}]];
               sol = NMinimize[Total[(y - fdata)^2 /. {x -> xi, y -> yi}], coeff][[2]];
               ListPlot[{data, Table[{x, fdata /. sol}, {x, 0.9, 7.6, .001}]}, 
                         AxesLabel -> {x, y}, 
                         AxesOrigin -> {0, 0},
                         GridLines -> Automatic,  
                         PlotLegends -> Placed[Style[StringJoin["polynomial of degree ", 
                                                     ToString[n]], Red], {.5, .5}],
                         PlotRange -> {{0, 7.6}, {0, 5.0}},
                         PlotStyle -> {Black, Red}], 
               {n, 0, 9}];
Export["animation.gif", frames, "AnimationRepetitions" -> ∞, "DisplayDurations" -> 1];

you can visually realize how "wrong" you are:

Is there a tool to graph a function and have it compute its actual formula?

1 Answers1