2
$\begingroup$

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:

enter image description here

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:

enter image description here

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.

$\endgroup$
  • $\begingroup$ Are you asking about some sort of "de-trending" ? $\endgroup$ – Anton Antonov Oct 25 at 17:17
  • $\begingroup$ Here is a related question. $\endgroup$ – Anton Antonov Oct 25 at 17:19
  • $\begingroup$ @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. $\endgroup$ – John Oct 25 at 17:24
  • 1
    $\begingroup$ "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. $\endgroup$ – Anton Antonov Oct 25 at 17:28
6
$\begingroup$

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]

enter image description here

De-trend the (filtered) data:

qrObj1 = MyDetrending[data2];

enter image description here

enter image description here

Get the corresponding values:

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

enter image description here

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

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – John Oct 25 at 17:42
  • $\begingroup$ 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. $\endgroup$ – John Oct 25 at 18:20
  • 1
    $\begingroup$ 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 ! $\endgroup$ – John Oct 25 at 18:41
1
$\begingroup$

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]

enter image description here

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

enter image description here

The second is the data without the first bump.

enter image description here

and the third is the data without the last bump.

enter image description here

| improve this answer | |
$\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.