5
$\begingroup$

I need to find an analytical expression for the data collected from an image.

I found a relevant topic on how to extract the data in here. But there are some differences in my question.

I have this picture:

enter image description here

Now I can get the position of each white pixel

pic = Import["http://i.stack.imgur.com/9uBnQ.png"]

pos = pic // Thinning // PixelValuePositions[#, 1] &;


ListPlot[pos]

Mathematica graphics

My first thought was FindFormula.

But the result as you see is

In[22]:= FindFormula[pos]    
Out[22]= 143.798 &

If use the FindFit, what's the model should be try?

And can we fit it in the case of not knowing the model?

$\endgroup$
4
  • 3
    $\begingroup$ Why the close votes? It is clear what its been asked: The OP needs to find an analytical expression for the data collected from an image. $\endgroup$ – rhermans Nov 12 '15 at 10:41
  • 1
    $\begingroup$ More luck may be had by translating the center of this to the origin and then thinking of some function in polar coordinates that could, perhaps, do this. $\endgroup$ – LLlAMnYP Nov 12 '15 at 11:04
  • $\begingroup$ This might get you started: pospol = {ArcTan[#1, #2], Norm[{#1, #2}]} & @@@ N[pos] then ListPlot[pospol]. Note the periodic function which looks something like a Abs[Sin[b x + c]]^d + e, but also there is some drift in parameters $\endgroup$ – LLlAMnYP Nov 12 '15 at 11:37
  • 1
    $\begingroup$ Forgot to mention, first you need to do pos = (# - Mean@pos)&/@pos to translate this to the origin. After all this and normalization I got the following plot: i.stack.imgur.com/TPQoH.png $\endgroup$ – LLlAMnYP Nov 12 '15 at 11:41
5
$\begingroup$

Another approach that might be successful with some additional fine tuning.

pos = (pic = Import["http://i.stack.imgur.com/9uBnQ.png"]) // 
    Thinning // PixelValuePositions[#, 1] &;

center = Mean /@ Transpose[pos] // N;

out = Reap[
     Module[{nextPos = {pos[[690]]}, newList = pos, delta = {-1., 1.},
        lastPos = {pos[[690]]}},
      Do[
       {nextPos, newList} = 
        TakeDrop[newList, 
         First@Position[#, 
             First@MinimalBy[TakeSmallestBy[#, (Norm[#, 1] &), 5], (Norm[# + delta, 1] &)]] &
          [Transpose[newList] - First@nextPos // Transpose]];
       delta = (7*delta + 1*First[(lastPos - nextPos)] - 
           0.0039*First[({center} - lastPos)])/8.0039;
       lastPos = Sow[nextPos];,
       {866}
       ]
      ]][[2, 1]] ~Flatten~ 1;

One can use

Manipulate[
 Show[{ListPlot[out[[;; n]], PlotMarkers -> {Automatic, 12}], 
   ListPlot[pos, PlotStyle -> Red]}, AspectRatio -> 1],
 {n, 2, Length@out, 1}]

to explore the creation of out.

Trying to find an analytical function using FindFormula

formula = 
 FindFormula[#, PerformanceGoal -> "Quality", 
    SpecificityGoal -> "Low", TargetFunctions -> {Sin, Cos, Power, Plus, Times}] & /@ 
  Transpose[out]

Plotting the results in comparison to the original data.

Show[{ListPlot[out, PlotStyle -> Gray, PlotMarkers -> {Automatic, 7}],
   ListPlot[pos, PlotStyle -> Red, PlotMarkers -> {Automatic, 3}],
  ParametricPlot[Through[formula[p]], {p, 1, Length@pos}, 
   PlotStyle -> Hue[0.6]]},
 AspectRatio -> 1]

enter image description here

Show[pic, %]

enter image description here

Show[ListPlot[Transpose@out], 
 Plot[Evaluate@Through[formula[x]], {x, 1, 1580}]]

enter image description here

ListPlot[{Reverse@out[[All, 1]], out[[All, 2]]}]

enter image description here

$\endgroup$
4
$\begingroup$

Not so much of an answer, but an extended comment, but I think I have it very nearly nailed:

pos2 = (# - Mean@pos & /@ (N@pos)) // #/Mean@(Norm /@ #) &
    Manipulate[
 Show[ListPlot[Reverse /@ pos2], 
  PolarPlot[Sqrt[a b]/Sqrt[
   a^2 Cos[c x]^2 + b^2 Sin[c x]^2], {x, -4.1 \[Pi], 4.1 \[Pi]}, 
   PlotStyle -> Orange]], {a, 1, 15}, {b, 1, 15}, {c, 1, 2}]

enter image description here

The expression under PolarPlot is the expression for an ellipse in polar coordinates relative to the center, except instead of x I have c x there so an error in phase accumulates just like can be seen in the data.

$\endgroup$
1
  • $\begingroup$ Thanks for your help.But find Sqrt[a b]/Sqrt[a^2 Cos[c x]^2 + b^2 Sin[c x]^2] is too hard for me.T_T $\endgroup$ – yode Nov 12 '15 at 12:31

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.