0
$\begingroup$

I have a numerical data by this code

data=Uncompress[FromCharacterCode@
  Flatten[ImageData[Import["https://i.stack.imgur.com/OiZrp.png"],"Byte"]]]

And I want to find the area of that shape as shown in the figure. How do I approach this problem in Mathematica? The issue is that length at say 50 and 50.5 can be very different.

enter image description here

What I tried to do was to negate the y values and align the horizontal as zero, so that Interpolation would do the job. Any clever ideas?

$\endgroup$
4
  • 1
    $\begingroup$ Is this question about software Mathematica or about signal processing? In its current form this question may be more appropriate for dsp.stackexchange.com. $\endgroup$ Apr 2 '17 at 10:06
  • $\begingroup$ Yes Alexey , How to do this in mathematica $\endgroup$
    – TM90
    Apr 2 '17 at 10:20
  • $\begingroup$ I have mentioned that $\endgroup$
    – TM90
    Apr 2 '17 at 10:21
  • 4
    $\begingroup$ How to you exactly define "the area here"? $\endgroup$
    – anderstood
    Apr 2 '17 at 12:50
6
$\begingroup$

There are many anwsers already, but i want to point out a (in my opinion) simpler approach. Just use Mathematicas Area build-in.

(Your data is in data)

lineHeight = 0.55;
sData = {{data[[-1, 1]], lineHeight}, {data[[1, 1]], lineHeight}}~ Join~data;
(*append data with edgepoints*)
sData[[All, 2]] = Min[lineHeight, #] & /@ sData[[All, 2]];
(*comment this line if you wan to have no clipping*)
poly = Polygon[sData]; (*make the polygon*)
ListLinePlot[data, PlotRange -> All, Epilog -> {Gray, poly}, ImageSize -> Large]
(*plot it*)
Area@poly (*calc the area*)

With clipping:

enter image description here 0.00392424

Without clipping:

enter image description here 0.00626118

BTW: an interpolation can add more unwanted area because it smoothes between the points. Its on your behalf to decide if you want that.

$\endgroup$
5
  • $\begingroup$ Thank you very much, Julien Kluge , This is exactly what I want $\endgroup$
    – TM90
    Apr 2 '17 at 22:56
  • $\begingroup$ @ Julien, When use Needs["polytopes`"]. It loads successfully but Area function is in red color? and whenever I compute this, the system crashes $\endgroup$
    – TM90
    Apr 3 '17 at 1:41
  • $\begingroup$ What version are you using, @TM90? Area[] has been built-in since version 10. What are you using the Polytopes package for? $\endgroup$ Apr 3 '17 at 2:55
  • $\begingroup$ @ J.M 11.0 version. When I tried to do this even without polytopes, it had been crashing $\endgroup$
    – TM90
    Apr 3 '17 at 5:09
  • $\begingroup$ What is polytopes for? The code should work out of the box. $\endgroup$ Apr 3 '17 at 17:06
3
$\begingroup$

The line on your plot looks like

line[x_] = InterpolatingPolynomial[{{50, 0.56}, {50.5, 0.55}}, x];
SetAttributes[line, Listable]

And the data curve is

interpolant[x_] = Interpolation[data, x, InterpolationOrder -> 1];

So your plot is

Plot[{line[x], interpolant[x]},
 {x, Sequence @@ MinMax[data[[All, 1]]]}, PlotRange -> All]

First find which data points are near the roots between the difference of the curves. I take the longest sequence without sign changes and include the first occurrence of different sign in both ends, because the roots are between different signs:

roots = With[{Q = Length /@ SplitBy[line[data[[All, 1]]] - data[[All, 2]], Sign]},
           Accumulate[Q][[Join[# - 1, #]]] &[Ordering[Q, -1]] + {{0, 1}, {0, 1}}]

Then the integration limits:

lims = x /. FindRoot[line[x] - interpolant[x], {x, data[[#, 1]], data[[#2, 1]]}] & @@@ roots

Result:

Integrate[line[x], {x, Sequence @@ lims}] -
 Integrate[interpolant[x], {x, Sequence @@ lims}]

0.0042779763

$\endgroup$
4
  • 3
    $\begingroup$ down vote? Would you please tell why.. $\endgroup$
    – Coolwater
    Apr 2 '17 at 11:22
  • 4
    $\begingroup$ Maybe the DV is because you don't use Tai's Method :) But seriously, yours is a reasonable approach to a reasonable interpretation of the question. (What might deserve a DV is the question, which is not clear: It's impossible to tell which of the approaches posted give a correct answer.) -- BTW, you can get an antiderivative of a non-spline InterpolatingFunction more quickly than integrating it. Use Integrate[interpolant[x], x] or Evaluate@Integrate[interpolant[#], #] &. (Speed is not really important here, though.) $\endgroup$
    – Michael E2
    Apr 2 '17 at 13:50
  • $\begingroup$ Okay, I upvoted, in part to offset the down vote. I have to say, the link from @MichaelE2 cracked me up. And I agree, the approach in this response seems fine. $\endgroup$ Apr 2 '17 at 15:24
  • $\begingroup$ @Coolwater, Thank you very much for your reply.This is more or less that I want. $\endgroup$
    – TM90
    Apr 2 '17 at 22:57
3
$\begingroup$

Writing:

data = {{50., 0.55403}, ..., {50.5, 0.553796}};
bar = 0.56;

ListLinePlot[{data, {{First[data][[1]], bar}, {Last[data][[1]], bar}}}, 
             PlotRange -> All, 
             Filling -> {1 -> {2}},
             AxesLabel -> {x, y} 
            ] 

Integrate[1, 
         {x, First[data][[1]], Last[data][[1]]}, 
         {y, Min[Interpolation[data][x], bar], Max[Interpolation[data][x], bar]}
         ] // N

I get:

enter image description here

0.00677696008549726

which are the graph and the desired area.

$\endgroup$
2
  • 1
    $\begingroup$ @ Manu This is not what I want, The thing you showed is just area under the curve. what I need is the area I mentioned between the curve and the straight line. $\endgroup$
    – TM90
    Apr 2 '17 at 10:50
  • $\begingroup$ ,Thank you very much and I agree $\endgroup$
    – TM90
    Apr 2 '17 at 22:54

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.