Restar picos de la curva

Question

Si tengo los siguientes datos:

https://pastebin.com/2jgDw4iQ

que trazó usando el siguiente código

ListLinePlot[data, 
 PlotStyle -> Directive[Thick, Black], 
 PlotRange -> {{70, 110}, {-0.2, 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}]

da:

Preguntas:

1. ¿Cómo se pueden eliminar los dos picos (ver imagen a continuación para aclarar) de la curva para obtener exactamente la misma curva sin esos dos picos?

Los dos picos, representados en azul y verde (no muy bien ajustados, pero para que te hagas una idea), son como se muestra en la siguiente figura:

Otra forma de preguntar lo mismo es: ¿Cómo puedo quitar los dos picos para que en lugar de picos simplemente tenga una línea a cero en la región donde se encuentran los picos ?.

1. ¿Cómo puedo restar solo el pico 1 (en azul) o solo el pico 2 (en verde) dejando el otro intacto?

Nota: La línea de base para los dos picos de direcciones opuestas es cero.

Answer 1

A continuación, estoy usando el software mónada QRMon, pero el código se puede modificar con relativa facilidad para usar la función de recursos QuantileRegression.

Datos

data = Get["https://pastebin.com/raw/2jgDw4iQ"];

Definiciones

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MonadicProgramming/MonadicQuantileRegression.m"]

Clear[MyDetrending];
MyDetrending[data_, knots_ : 16, opts : OptionsPattern[]] :=
  Block[{lsDefaultOpts = Sequence @@ {PlotTheme -> "Detailed", AspectRatio -> 1/2, ImageSize -> Large}},
   QRMonUnit[data]⟹
    QRMonQuantileRegression[knots, 0.5]⟹
    QRMonPlot[PlotStyle -> {GrayLevel[0.8], PointSize[0.008]}, lsDefaultOpts, opts]⟹
    QRMonErrorPlots["RelativeErrors" -> False, Filling -> False, Joined -> True, lsDefaultOpts, opts]
   ];

De-tendencia con QRMon

De tendencia global

¿Cómo puedo eliminar los dos picos para que en lugar de picos simplemente tenga una línea en cero en la región donde se encuentran los picos?

Filtre los datos para adherirse a los gráficos de la pregunta:

data2 = Select[data, 75 <= #[[1]] <= 110 &];
ResourceFunction["RecordsSummary"][data2]

Elimine la tendencia de los datos (filtrados):

qrObj1 = MyDetrending[data2];

Obtenga los valores correspondientes:

deTrendedData = (qrObj1\[DoubleLongRightArrow]QRMonErrors[
      "RelativeErrors" -> 
       False]\[DoubleLongRightArrow]QRMonTakeValue)[0.5];
ListLinePlot[deTrendedData]

Des-tendencia local

¿Cómo puedo restar solo el pico 1 (en azul) o solo el pico 2 (en verde) dejando el otro intacto?

Obtener una tendencia local:

qrObj2 = MyDetrending[Select[data, 79 <= #[[1]] <= 88 &], 4, "Echo" -> False];
qFunc = (qrObj2\[DoubleLongRightArrow]QRMonTakeRegressionFunctions)[0.5];

De-tendencia localizado:

deTrendedDataLocal1 =  Map[If[79 <= #[[1]] <= 88, {#[[1]], #[[2]] - qFunc[#[[1]]]}, #] &, data2];
ListLinePlot[deTrendedDataLocal1, Sequence @@ {PlotTheme -> "Detailed", AspectRatio -> 1/2,  ImageSize -> Large}]

Answer 2

Como producto de la inspección visual, tomando datos de $\approx 80$ a $120$ y usando el modelo

$$ f(a,b,\sigma_1,\sigma_2,x_1,x_2,x)=a e^{-\left(\frac{x-x_1}{\sigma_1}\right)^2}+b e^{-\left(\frac{x-x_2}{\sigma_2}\right)^2} $$

data = Get["https://pastebin.com/raw/2jgDw4iQ"];
reddata = Take[data, {990, Length[data]}];

f[a_, s1_, x1_, x_] := a Exp[-((x - x1)/s1)^2]
f[a_, b_, s1_, s2_, x1_, x2_, x_] := f[a, s1, x1, x] + f[b, s2, x2, x]
obj = Sum[(reddata[[k, 2]] - f[a, b, s1, s2, x1, x2, reddata[[k, 1]]])^2, {k, 1, Length[reddata]}];
sol = NMinimize[{obj, x2 > 90, x1 > 80, Abs[a] < 0.08, Abs[b] < 0.08}, {a, b, s1, s2, x1, x2}, Method -> "DifferentialEvolution"]

gr1 = Plot[fxk[x], {x, 75.5, 120}, PlotStyle -> {Thick, Blue}];
gr2 = ListPlot[reddata, PlotStyle -> Red];
Show[gr1, gr2]

Siguiendo con

datat = Transpose[reddata];
xk = datat[[1, All]];
fxk0 = Map[fxk, xk];
f10 = Map[f1, xk];
f20 = Map[f2, xk];
data0 = Transpose[{xk, fxk0}];
data1 = Transpose[{xk, f10}];
data2 = Transpose[{xk, f20}];
datacorr = reddata - fxk0;
datacorr1 = reddata - f10;
datacorr2 = reddata - f20;
ListLinePlot[datacorr, PlotStyle -> Blue]
ListLinePlot[datacorr1, PlotStyle -> Blue]
ListLinePlot[datacorr2, PlotStyle -> Blue]

Aquí podemos observar tres parcelas.

El primero son los datos sin ambos baches.

El segundo son los datos sin el primer golpe.

y el tercero son los datos sin el último golpe.