3
$\begingroup$

How do I measure the area between two curves that overlap at one point? Both curves are of different lengths so I would assume that I would first have to limit the range? I am trying to calculate the absolute difference between the curves.

The data for both curves:

x1 = {-0.221848749616356, -0.207584055650315, -0.193319361684274, 
-0.179054667718233, -0.164789973752192, -0.150525279786150, 
-0.136260585820109, -0.121995891854068, -0.107731197888027, 
-0.0934665039219856, -0.0792018099559444, -0.0649371159899032, 
-0.0506724220238620, -0.0364077280578208, -0.0221430340917796, 
-0.00787834012573838, 0.00638635384030281, 0.0206510478063440, 
  0.0349157417723852, 0.0491804357384264, 0.0634451297044676, 
  0.0777098236705088, 0.0919745176365500, 0.106239211602591 , 
  0.120503905568632, 0.134768599534674, 0.149033293500715, 
  0.163297987466756, 0.177562681432797, 0.191827375398838, 
  0.206092069364880, 0.220356763330921 , 0.234621457296962, 
  0.248886151263003 , 0.263150845229044, 0.277415539195086, 
  0.291680233161127, 0.305944927127168, 0.320209621093209, 
  0.334474315059250, 0.348739009025292, 0.363003702991333, 
  0.377268396957374, 0.391533090923415, 0.405797784889456, 
  0.420062478855498 , 0.434327172821539, 0.448591866787580, 
  0.462856560753621, 0.477121254719662}

y1 = {0.2266, 0.1878, 0.1510, 0.1159, 0.0826, 0.0509, 
  0.0208, -0.0079, -0.0351, -0.0611, -0.0857, -0.1092, -0.1315, 
-0.1527, -0.1728, -0.1920, -0.2102, -0.2276, -0.2441, -0.2598, 
-0.2747, -0.2889, -0.3024, -0.3152, -0.3274, -0.3390, -0.3500, 
-0.3605, -0.3705, -0.3800, -0.3890, -0.3976, -0.4058, -0.4136, 
-0.4210, -0.4280, -0.4347, -0.4410, -0.4470, -0.4528, -0.4583, 
-0.4635, -0.4684, -0.4731, -0.4776, -0.4818, -0.4859, -0.4897, 
-0.4934, -0.4968}

x2 = {-0.425195987318646, -0.379438496757971, -0.338045811599746, 
-0.300257250710346, -0.265495144451134, -0.233310461079733, 
-0.175318514102046, -0.148989575379697, -0.100684895805142, 
-0.0572192020240517, -0.0177106607403781, 0.0185015119140666, 
  0.0519252674010163, 0.0976827579616914, 0.139075443119917, 
  0.176864004009316, 0.222621494569991, 0.264014179728217, 
  0.301802740617616, 0.344837372842818, 0.383989496804966, 
  0.426741477225916, 0.465659543256286, 0.507052228414511, 
  0.544840789303911}

y2 = {1.98977028898017, 1.61591642101008, 1.32130458152091, 
  1.08402347810582 , 0.889420233704868, 0.727354573106834, 
  0.473895440336041, 0.373297476340392, 0.209165818511101, 
  0.0814476833288233, -0.0203553720851161, -0.103127353871147, 
-0.171554952110805, -0.254243003377083, -0.319404503563252, 
-0.371885736806178, -0.427585958833350, -0.471479967367961, 
-0.506832310289645, -0.542268987260499, -0.570576160634482, 
-0.597734852914923, -0.619460166116272, -0.639813078961169, 
-0.656205365251891}

DataPic

$\endgroup$
  • $\begingroup$ Can you please post the data in your post, properly edited in code blocks? Or at least, post the code that would allow us to generate the points? $\endgroup$ – march Nov 29 '16 at 17:25
  • 1
    $\begingroup$ Also edit question to define how you want area to be measured? Are both regions positive or is one negative? Which? $\endgroup$ – Bob Hanlon Nov 29 '16 at 17:28
  • $\begingroup$ You could use InterpolatingFunction and NIntegrate. $\endgroup$ – anderstood Nov 29 '16 at 17:31
  • $\begingroup$ You can format inline code and code blocks by selecting the code and clicking the {} button above the edit window. The edit window help button ? is useful for learning how to format your questions and answers. You may also find this meta Q&A helpful -- using semicolons to suppress irrelevant output would be considerate, too. $\endgroup$ – Michael E2 Nov 29 '16 at 17:33
10
$\begingroup$

Here is the area you are interested in,

plot = ListLinePlot[Transpose /@ {{x1, y1}, {x2, y2}}, 
  Filling -> {1 -> {2}}]

Mathematica graphics

Extract it using Cases,

inBetween = Cases[Normal@plot, _Polygon, Infinity];
Graphics@inBetween

Mathematica graphics

And then just grab the Area,

Total[Area /@ inBetween]
(* 0.0956571 *)

You can get a similar answer by making an interpolating function and integrating:

funcs = Interpolation@*Transpose /@ {{x1, y1}, {x2, y2}};
NIntegrate[
 Abs[funcs[[1]][x] - funcs[[2]][x]], {x, -0.221848749616356`, 
  0.477121254719662`}]
(* 0.0952311 *)
$\endgroup$
  • $\begingroup$ I would also like to calculate whether there is a significant difference between the two curves but only for the area. Is there an easy way to do that? $\endgroup$ – Tim Shepard Nov 29 '16 at 18:29
  • $\begingroup$ I'm not sure I understand your question - what do you mean by "significant difference"? $\endgroup$ – Jason B. Nov 29 '16 at 18:30
  • $\begingroup$ @TimShepard Do you mean the ratio between the black area and the are under one of the curves? If it's small, it means both curves are similar. Kind of a relative error (don't forget the absolute values). $\endgroup$ – anderstood Nov 29 '16 at 18:31
  • $\begingroup$ @anderstood - feel free to edit this answer if you understand the question more, I made it a wiki :-) $\endgroup$ – Jason B. Nov 29 '16 at 18:32
7
$\begingroup$
x1 = {-0.221848749616356, -0.207584055650315, -0.193319361684274, \
-0.179054667718233, -0.164789973752192, -0.150525279786150, \
-0.136260585820109, -0.121995891854068, -0.107731197888027, \
-0.0934665039219856, -0.0792018099559444, -0.0649371159899032, \
-0.0506724220238620, -0.0364077280578208, -0.0221430340917796, \
-0.00787834012573838, 0.00638635384030281, 0.0206510478063440, 
   0.0349157417723852, 0.0491804357384264, 0.0634451297044676, 
   0.0777098236705088, 0.0919745176365500, 0.106239211602591, 
   0.120503905568632, 0.134768599534674, 0.149033293500715, 0.163297987466756,
    0.177562681432797, 0.191827375398838, 0.206092069364880, 
   0.220356763330921, 0.234621457296962, 0.248886151263003, 0.263150845229044,
    0.277415539195086, 0.291680233161127, 0.305944927127168, 
   0.320209621093209, 0.334474315059250, 0.348739009025292, 0.363003702991333,
    0.377268396957374, 0.391533090923415, 0.405797784889456, 
   0.420062478855498, 0.434327172821539, 0.448591866787580, 0.462856560753621,
    0.477121254719662};
y1 = {0.2266, 0.1878, 0.1510, 0.1159, 0.0826, 0.0509, 
   0.0208, -0.0079, -0.0351, -0.0611, -0.0857, -0.1092, -0.1315, -0.1527, \
-0.1728, -0.1920, -0.2102, -0.2276, -0.2441, -0.2598, -0.2747, -0.2889, \
-0.3024, -0.3152, -0.3274, -0.3390, -0.3500, -0.3605, -0.3705, -0.3800, \
-0.3890, -0.3976, -0.4058, -0.4136, -0.4210, -0.4280, -0.4347, -0.4410, \
-0.4470, -0.4528, -0.4583, -0.4635, -0.4684, -0.4731, -0.4776, -0.4818, \
-0.4859, -0.4897, -0.4934, -0.4968};
x2 = {-0.425195987318646, -0.379438496757971, -0.338045811599746, \
-0.300257250710346, -0.265495144451134, -0.233310461079733, \
-0.175318514102046, -0.148989575379697, -0.100684895805142, \
-0.0572192020240517, -0.0177106607403781, 0.0185015119140666, 
   0.0519252674010163, 0.0976827579616914, 0.139075443119917, 
   0.176864004009316, 0.222621494569991, 0.264014179728217, 0.301802740617616,
    0.344837372842818, 0.383989496804966, 0.426741477225916, 
   0.465659543256286, 0.507052228414511, 0.544840789303911};
y2 = {1.98977028898017, 1.61591642101008, 1.32130458152091, 1.08402347810582, 
   0.889420233704868, 0.727354573106834, 0.473895440336041, 0.373297476340392,
    0.209165818511101, 
   0.0814476833288233, -0.0203553720851161, -0.103127353871147, \
-0.171554952110805, -0.254243003377083, -0.319404503563252, \
-0.371885736806178, -0.427585958833350, -0.471479967367961, \
-0.506832310289645, -0.542268987260499, -0.570576160634482, \
-0.597734852914923, -0.619460166116272, -0.639813078961169, \
-0.656205365251891};

The sets of points are

pts1 = Transpose[{x1, y1}];
pts2 = Transpose[{x2, y2}];

The Interpolation functions are

f1 = Interpolation[pts1];
f2 = Interpolation[pts2];

The regions are

Show[
 Plot[
  {Tooltip[f1[x], "f1"], f2[x]},
  {x, Min[x1], Max[x1]},
  PlotStyle -> Blue,
  Filling -> {1 -> {{2}, {LightRed, LightBlue}}}],
 Plot[
  Tooltip[f2[x], "f2"],
  {x, Min[x2], Max[x2]},
  PlotStyle -> Red],
 PlotRange -> All]

enter image description here

Red minus Blue

area1 = NIntegrate[f2[x] - f1[x],
  {x, Min[x1], Max[x1]}]

0.050805

Red plus Blue

area2 = NIntegrate[Abs[f1[x] - f2[x]],
  {x, Min[x1], Max[x1]}]

0.0952311
$\endgroup$
4
$\begingroup$

Here's one interpretation of the (absolute) area between the connected dots:

Area@Polygon[Join[Transpose[{x1, y1}], Reverse@Transpose[{x2, y2}]]]
(*  0.131786  *)

enter image description here

$\endgroup$
  • 1
    $\begingroup$ The OP does not explain clearly what area he is looking for; this "extrapolates" the short curve to join the long curve, which explains the discrepancy with the other solutions which truncate the domain to the smallest. $\endgroup$ – anderstood Nov 29 '16 at 18:30
  • 1
    $\begingroup$ @anderstood Yes, quite right. It's not clear what "between the curves" means exactly. (There aren't even any curves defined in the question, which is why I emphasized connecting the dots.) $\endgroup$ – Michael E2 Nov 29 '16 at 18:49
  • $\begingroup$ It's simple enough to restrict the region in this answer to range of x with a Rectangle: Area[RegionIntersection[DiscretizeRegion@Rectangle[{Max[Min /@ {x1, x2}], -1}, {Min[Max /@ {x1, x2}], 2}], DiscretizeRegion@Polygon[Join[Transpose[{x1, y1}], Reverse@Transpose[{x2, y2}]]]]] $\endgroup$ – Michael E2 Nov 29 '16 at 19:36

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.