Ajustement de pics avec condition de contrainte de même surface

Question

Si j'ai les données suivantes:

https://pastebin.com/RFVd0MpU

Ce qui tracé entre 60 et 100 (celsius) en utilisant le code suivant, donne:

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}]

Des questions:

1. Comment puis-je ajuster les deux pics dans les directions opposées (voir image ci-dessous) sachant que les deux pics ont la même surface?
2. Comment puis-je trouver l'aire des deux pics?.

Notez que la ligne de base pour les deux pics est à zéro.

Telle est ma démarche jusqu'à présent. Comme vous pouvez le voir, je suis proche mais j'espère que quelqu'un ici pourra m'aider à améliorer ce qui manque:

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]

Qui donne:

Answer 1

Voici un ajustement aux données:

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]}]

Les zones que vous pouvez obtenir à partir de:

{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}*)

Cependant, notez que vos hypothèses de "la ligne de base pour les deux pics est à zéro" ne sont évidemment pas correctes.

Answer 2

Voici un exemple que vous pouvez adapter à vos données pour ajuster une spline à des points donnés. Cet exemple ajuste une courbe aux points d'un potentiel Morse. Vous pouvez déplacer le localisateur pour adapter la fonction:

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}]
   ]]

Si vous avez finalement obtenu les points dans "loc", vous pouvez créer une fonction que vous pouvez utiliser pour soustraire la ligne de base:

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]]}]