# Subtract peaks from curve

If I have the following data:

https://pastebin.com/2jgDw4iQ

which plotted using the following code

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


gives:

Questions:

1. How can remove the two peaks (see image below for clarification) of the curve to obtain exactly the same curve without those two peaks?

The two peaks, represented in blue and green (not very well fitted, but to give you an idea), are as shown in the figure below:

Another way to ask the same is: How can I remove the two peaks so that instead of peaks I simply have a line at zero in the region where the peaks are located?.

1. How can I subtract only the peak 1 (in blue) or only the peak 2 (in green) while leaving the other intact?

Note: The baseline for the two peaks of opposite directions is at zero.

• Are you asking about some sort of "de-trending" ? – Anton Antonov Oct 25 at 17:17
• Here is a related question. – Anton Antonov Oct 25 at 17:19
• @AntonAntonov thank you for your commnet. The related question that you posted was posted by me before and it it a very very very different question. In that question I was asking about how to fit those two peaks (with a different data set). In this one, I am asking how to remove those two peaks. – John Oct 25 at 17:24
• "The related question that you posted was posted by me before [...]" -- That is totally fine. I mentioned that other question in a comment so its page to be explicitly linked to this one by MSE. – Anton Antonov Oct 25 at 17:28

Below I am using the software monad QRMon, but the code can be relatively easily modified to use the resource function QuantileRegression.

## Data

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


## Definitions

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-trending with QRMon

### Global de-trending

How can I remove the two peaks so that instead of peaks I simply have a line at zero in the region where the peaks are located?.

Filter the data to adhere to question’s plots:

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


De-trend the (filtered) data:

qrObj1 = MyDetrending[data2];


Get the corresponding values:

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


### Local de-trending

How can I subtract only the peak 1 (in blue) or only the peak 2 (in green) while leaving the other intact?

Getting a local trend:

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


Localized de-trending:

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


• Hi Anton, yes, it seems that way. Thank you!. From question 1, pretty much if I get exactly the same curve but instead of both peaks I get a line around zero (which is when the two peaks are subtracted, then that works. – John Oct 25 at 17:42
• Anton, thank you very much. This looks great. But I have two questions: 1) Where is the rest of the data of the curve from 20 all the way to around 75? or from 110 to 120?2) How can I also remove the second peak?. I would like to have the same exact intact data that I posted but without the two peaks. From what I can see or understand, only the data from around 76 to 110 is there. – John Oct 25 at 18:20
• Anton, never mind the last comment. I was able to figure out the two questions I asked. Thank you very much for your help! I really appreciate it ! – John Oct 25 at 18:41

As a product of visual inspection, taking data from $$\approx 80$$ to $$120$$ and using the model

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


Following with

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]


Here we can observe three plots.

The first is the data without both bumps

The second is the data without the first bump.

and the third is the data without the last bump.