2
$\begingroup$

If I have the following data:

https://pastebin.com/RFVd0MpU

Which plotted between 60 to 100 (celsius) using the following code, gives:

ListLinePlot[datawithnoliquidline, 
 PlotStyle -> Directive[Thick, Black], 
 PlotRange -> {{60, 110}, {-0.5, All}}, Frame -> True, 
 FrameStyle -> 14, Axes -> False, GridLines -> Automatic, 
 GridLinesStyle -> Lighter[Gray, .8], 
 FrameTicks -> {Automatic, Automatic}, 
 FrameLabel -> (Style[#, 20, Bold] & /@ {"T (\[Degree]C)", 
     Row[{"\!\(\*SubscriptBox[\(C\), \(P\)]\)", " (", " J/gK)"}]}), 
 LabelStyle -> {Black, Bold, 14}]

enter image description here

Questions:

  1. How can I fit the two peaks in the opposite directions (see image below) knowing that both peaks have the same area?
  2. How can I find the area of both peaks?.

Note the baseline for both peaks is at zero.

This is my approach so far. As you can see I am close but I am hoping someone here can help me improve what is missing:

ma5guess = 5;
siga5guess = 8;
ma3guess = 1.3;
siga3guess = 3;
meda3guess = 97;
meda5guess = 75;

ff2[x_, areaa3_, areaa5_, siga3_, meda3_, meda5_, siga5_] := 
  areaa3 PDF[NormalDistribution[meda3, siga3], x] - 
   areaa5 PDF[SkewNormalDistribution[meda5, siga5, -5], x] ;

nlm3 = NonlinearModelFit[
   datawithnoliquidline, {ff2[x, areaa3, areaa5, siga3, meda3, meda5, 
     siga5], areaa3 >=  0, meda3 - 2*siga3 > 80, 
    68 < meda5 - 2*siga5 < meda3 - 2*siga3}, {{areaa3, 
     ma3guess}, {areaa5, ma5guess}, {siga3, siga3guess}, {meda3, 
     meda3guess}, {meda5, meda5guess}, {siga5, siga5guess}}, x];

fp = nlm3["BestFitParameters"];

p1 =(*Original data*)
  ListLinePlot[datawithnoliquidline, 
   PlotStyle -> Directive[Thick, Black], 
   PlotRange -> {{40, 110}, {-0.5, All}}, Frame -> True, 
   FrameStyle -> 14, Axes -> False, GridLines -> Automatic, 
   GridLinesStyle -> Lighter[Gray, .8], 
   FrameTicks -> {Automatic, Automatic}, 
   FrameLabel -> (Style[#, 20, Bold] & /@ {"T (\[Degree]C)", 
       Row[{"\!\(\*SubscriptBox[\(C\), \(P\)]\)", " (", " J/gK)"}]}), 
   LabelStyle -> {Black, Bold, 14}];

p2b = Plot[{nlm3[x], 
    areaa3 PDF[NormalDistribution[meda3, siga3], x] /. 
     fp, -areaa5 PDF[SkewNormalDistribution[meda5, siga5, -5], x] /. 
     fp}, {x, 40, 110}, 
   PlotStyle -> {Directive[Red, Dashing[{0.02, 0.04}], 
      AbsoluteThickness[5]], Directive[Green, AbsoluteThickness[2]], 
     Directive[Orange, AbsoluteThickness[2]]}, PlotRange -> All];

Show[p1, p2b]

Which gives:

enter image description here

$\endgroup$
1
  • 3
    $\begingroup$ I believe your problem is ill-posed. If you could prescribe the shape of the peak (for instance a Gaussian curve) and the two ranges where you want to fit them, then you could minimize a cost without two much difficulty. $\endgroup$
    – anderstood
    Oct 24 '20 at 12:26
2
$\begingroup$

Here is a fit to the data:

f[x_] = p1 Exp[-(x - p2)^2 p3] + p4 Exp[-(x - p5)^2 p6] /. 
  FindFit[dat1, 
   p1 Exp[-(x - p2)^2 p3] + p4 Exp[-(x - p5)^2 p6], {p1, {p2, 75}, p3,
     p4, {p5, 90}, p6}, x]
Plot[f[x], {x, dat1[[1, 1]], dat1[[-1, 1]]}, 
 Epilog -> {PointSize[0.001], Point[dat1]}]

enter image description here

The areas you can get from:

{f1[x_], f2[x_]} = {p1 Exp[-(x - p2)^2 p3], 
    p4 Exp[-(x - p5)^2 p6]} /. 
   FindFit[dat1, 
    p1 Exp[-(x - p2)^2 p3] + p4 Exp[-(x - p5)^2 p6], {p1, {p2, 75}, 
     p3, p4, {p5, 90}, p6}, x];
Integrate[{f1[x], f2[x]}, {x, 60, 110}]
(*{-1.35076, 1.02609}*)

However, note that the your assumptions of "the baseline for both peaks is at zero" is obviously not right.

$\endgroup$
11
  • $\begingroup$ Daniel, thank you very much for your answer. However, when I put your code as it is and change the name of the data to "dat1" and get "FindFit::cvmit: Failed to converge to the requested accuracy or precision within 100 iterations.". Also the peak 1 seems to be cut and it is unclear the fit for that peak. Did you cut the data or use it as it was in the post? $\endgroup$
    – John
    Oct 23 '20 at 17:16
  • $\begingroup$ Hi John,I did only use data from approx. 70 to 115 degree. I tried to reproduce it. I copied/pasted your data: dat0={{...},{...},...} Then I take a part: dat1 = dat0[[2400 ;; 3800]]; Then the result from the fit is: {p1 -> -0.107358, p2 -> 75.6448, p3 -> 0.0198087, p4 -> 0.170771, p5 -> 89.1813, p6 -> 0.0870177} $\endgroup$ Oct 23 '20 at 18:19
  • 1
    $\begingroup$ Try subtracting a base line to make the base more constant, then the fit should be easier. $\endgroup$ Oct 23 '20 at 18:43
  • 1
    $\begingroup$ Hi John, I do not think this is correct. You are fitting two functions with baselines of zero to some data that has a very curved baseline. To judge the fit you need to plot the error. And the error will be bad because your data has a very konvex baseline, you can not simply ignore this. The thing to do is to first subtract the baseline, then do the fit and then add the baseline again. Another approach is to use fit-functions that do not assume a baseline of zero. Note, the word convolution has another meaning than you think, look it up. I think you mean overlay. $\endgroup$ Oct 23 '20 at 19:19
  • 2
    $\begingroup$ That's "handwork". You could use e.g. some spline (read about it in the help, there are several different variety ). They have "control points," with which you can form a smooth curve of arbitrary shape. This can be done in e.g. a LocatorPane or in a Manipulate, but this will need some coding. When you have the curve, you calculate its value at the data points and subtract it. It would be easier if you know what determines the baseline, but in practice, this is often not the case. $\endgroup$ Oct 23 '20 at 19:56
2
$\begingroup$

Here is an example that you can adapt to your data for fitting a spline to given points. This example fits a curve to points from a Morse potential. You can move the locator to adapt the function:

pts = {{0, 10}, {1, 5}, {2, 2}, {3, 1}, {4, 2}, {5, 4}, {6, 5}, {7, 5.5}, {8, 6}};(*data points. Do not use too many data points, otherwise you will slow down the graphics*)
loc = {{1, 4}, {2, 1}, {4, 1}, {6, 3}, {7, 4}};(*locators*)
DynamicModule[{},
 Dynamic@Show[
   Graphics[{Locator[Dynamic[loc[[1]]]], Locator[Dynamic[loc[[2]]]], 
     Locator[Dynamic[loc[[3]]]], Locator[Dynamic[loc[[4]]]], 
     Locator[Dynamic[loc[[5]]]], 
     spline = 
      BezierCurve[Join[{pts[[1]]}, loc, {pts[[-1]]}], 
       SplineDegree -> (Length@loc + 1)], {PointSize[0.02], Red, 
      Point[pts]}}, Axes -> True, PlotRange -> {{-2, 10}, {-5, 12}}],
   ParametricPlot[spline[x], {x, 0, 10}]
   ]]

enter image description here

If you finally got the points in "loc" you can make a function that you can use to subtract the baseline:

bf = BezierFunction[Join[{pts[[1]]}, loc, {pts[[-1]]}]];
fun = Interpolation[Table[bf[t], {t, 0, 1, 0.05}]];
Plot[fun[x], {x, pts[[1, 1]], pts[[-1, 1]]}]
$\endgroup$

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.