12
$\begingroup$

I will try to be as informative as possible.

Clear["Global`*"]

I have the following data

data91 = {{-0.209091`, 2.89296`}, {0.281818`, 2.92958`}, {0.8`, 
    2.97535`}, {1.28182`, 3.03028`}, {1.8`, 3.07606`}, {2.28182`, 
    3.11268`}, {2.5`, 3.1493`}, {2.8`, 3.18592`}};

data88 = {{-0.2`, 2.74648`}, {0.272727`, 2.79225`}, {0.8`, 
    2.83803`}, {1.27273`, 2.8838`}, {1.80909`, 2.92958`}, {2.28182`, 
    2.95704`}, {2.50909`, 2.99366`}, {2.8`, 3.03028`}};

data85 = {{-0.209091`, 2.58169`}, {0.272727`, 2.63662`}, {0.790909`, 
    2.69155`}, {1.27273`, 2.74648`}, {1.8`, 2.77394`}, {2.28182`, 
    2.81972`}, {2.50909`, 2.82887`}, {2.8`, 2.87465`}};

data82 = {{-0.2`, 2.43521`}, {0.281818`, 2.49014`}, {0.8`, 
    2.55423`}, {1.27273`, 2.59085`}, {1.8`, 2.63662`}, {2.28182`, 
    2.66408`}, {2.50909`, 2.69155`}, {2.8`, 2.71901`}};

data79 = {{-0.2`, 2.27958`}, {0.281818`, 2.33451`}, {0.790909`, 
    2.38944`}, {1.27273`, 2.43521`}, {1.80909`, 2.48099`}, {2.28182`, 
    2.50845`}, {2.5`, 2.52676`}, {2.81818`, 2.56338`}};

data76 = {{-0.2`, 2.07817`}, {0.272727`, 2.14225`}, {0.790909`, 
    2.21549`}, {1.28182`, 2.27042`}, {1.80909`, 2.30704`}, {2.27273`, 
    2.36197`}, {2.5`, 2.37113`}, {2.8`, 2.40775`}};

data73 = {{-0.2`, 1.83099`}, {0.272727`, 1.93169`}, {0.790909`, 
    2.01408`}, {1.28182`, 2.07817`}, {1.80909`, 2.14225`}, {2.29091`, 
    2.16972`}, {2.50909`, 2.20634`}, {2.80909`, 2.2338`}};

data70 = {{-0.2`, 1.54718`}, {0.281818`, 1.65704`}, {0.8`, 
    1.77606`}, {1.29091`, 1.84014`}, {1.8`, 1.92254`}, {2.29091`, 
    1.97746`}, {2.50909`, 1.99577`}, {2.80909`, 2.03239`}};

data67 = {{-0.2`, 1.21761`}, {0.281818`, 1.32746`}, {0.8`, 
    1.47394`}, {1.27273`, 1.57465`}, {1.80909`, 1.6662`}, {2.28182`, 
    1.72113`}, {2.50909`, 1.7669`}, {2.80909`, 1.80352`}};

data64 = {{-0.2`, 0.869718`}, {0.263636`, 1.0162`}, {0.781818`, 
    1.15352`}, {1.29091`, 1.26338`}, {1.80909`, 1.39155`}, {2.29091`, 
    1.46479`}, {2.5`, 1.51972`}, {2.80909`, 1.55634`}};

data61 = {{-0.2`, 0.622535`}, {0.272727`, 0.714085`}, {0.809091`, 
    0.851408`}, {1.28182`, 0.988732`}, {1.79091`, 1.09859`}, {2.28182`, 
    1.21761`}, {2.5`, 1.25423`}, {2.81818`, 1.3`}};

data58 = {{-0.209091`, 0.411972`}, {0.272727`, 0.494366`}, {0.8`, 
    0.63169`}, {1.28182`, 0.723239`}, {1.80909`, 0.851408`}, {2.3`, 
    0.961268`}, {2.5`, 1.02535`}, {2.80909`, 1.07113`}};

data55 = {{-0.209091`, 0.265493`}, {0.281818`, 0.338732`}, {0.8`, 
    0.430282`}, {1.28182`, 0.521831`}, {1.8`, 0.640845`}, {2.28182`, 
    0.759859`}, {2.50909`, 0.796479`}, {2.80909`, 0.860563`}};

data52 = {{-0.209091`, 0.183099`}, {0.281818`, 0.219718`}, {0.790909`, 
    0.292958`}, {1.28182`, 0.375352`}, {1.80909`, 0.466901`}, {2.28182`, 
    0.576761`}, {2.49091`, 0.61338`}, {2.80909`, 0.677465`}};

data49 = {{-0.209091`, 0.109859`}, {0.272727`, 0.146479`}, {0.8`, 
    0.201408`}, {1.28182`, 0.256338`}, {1.80909`, 0.338732`}, {2.28182`, 
    0.430282`}, {2.50909`, 0.466901`}, {2.8`, 0.521831`}};

Here is their visualization:

    temps = -{91, 88, 85, 82, 79, 76, 73, 70, 67, 64, 61, 58, 55, 52, 49};
    ListLinePlot[{data91, data88, data85, data82, data79, data76, data73, 
data70, data67, data64, data61, data58, data55, data52, data49}, Frame -> True, 
     PlotRangePadding -> Scaled[0.1], Axes -> False, 
     PlotMarkers -> {{\[EmptyCircle], Medium}}, 
     PlotStyle -> Map[ColorData[{"Rainbow", {-91, -49}}], temps], 
     PlotLegends -> Quantity[temps, "DegreesCelsius"], ImageSize -> 600, 
     FrameLabel -> {"log\[Omega]", "E'(\!\(\*SubscriptBox[\(T\), \(0\)]\)/T)"}, 
     FrameStyle -> Directive[14], RotateLabel -> False]

enter image description here

-61oC is chosen as the reference temperature. What I want now is to shift horizontally the points of the other temperatures in order to construct a "master" curve at -61oC which spans a bigger range of log\[Omega] values. I can do this manually as follows

data49shift = data49 /. {x_, y_} -> {x - 3.5, y};
data52shift = data52 /. {x_, y_} -> {x - 2.8, y};
data55shift = data55 /. {x_, y_} -> {x - 2, y};
data58shift = data58 /. {x_, y_} -> {x - 1, y};
data64shift = data64 /. {x_, y_} -> {x + 1.2, y};
data67shift = data67 /. {x_, y_} -> {x + 2.5, y};
data70shift = data70 /. {x_, y_} -> {x + 4.1, y};
data73shift = data73 /. {x_, y_} -> {x + 5.8, y};
data76shift = data76 /. {x_, y_} -> {x + 7.4, y};
data79shift = data79 /. {x_, y_} -> {x + 8.9, y};
data82shift = data82 /. {x_, y_} -> {x + 10.6, y};
data85shift = data85 /. {x_, y_} -> {x + 12.2, y};
data88shift = data88 /. {x_, y_} -> {x + 14., y};
data91shift = data91 /. {x_, y_} -> {x + 15.7, y};

and the result is

ListLinePlot[{data91shift, data88shift, data85shift, data82shift, 
  data79shift, data76shift, data73shift, data70shift, data67shift, 
  data64shift, data61, data58shift, data55shift, data52shift, 
  data49shift}, Frame -> True, PlotRangePadding -> Scaled[0.1], 
 Axes -> False, PlotMarkers -> {{\[EmptyCircle], Medium}}, 
 PlotStyle -> Map[ColorData[{"Rainbow", {-91, -49}}], temps], 
 PlotLegends -> Quantity[temps, "DegreesCelsius"], ImageSize -> 600, 
 FrameLabel -> {"log\[Omega]", 
   "E'(\!\(\*SubscriptBox[\(T\), \(0\)]\)/T)"}, 
 FrameStyle -> Directive[14], RotateLabel -> False]

enter image description here

The article that I follow says that the authors made the horizontal shifting in OriginPro but they do not provide any further information. Since I do not have OriginPro I am trying to develop a less manual procedure in Mathematica. Any ideas?

The algorithm should be such, that given two sets of data (the one of the reference temperature and the one to be shifted) it will make the horizontal shifting and return the horizontal shift factor for the best possible shifting.

E.g. for data91 it will evaluate a value close to 15.7 that I found with the eye.

Thank you very much.

$\endgroup$
  • 1
    $\begingroup$ I don't think this question is about Mathematica. The problem is that you don't know what algorithm to use in order to calculate the horizontal shift, not that you don't know how to implement it. $\endgroup$ – yohbs Oct 7 '15 at 13:41
  • $\begingroup$ Should I delete the question? $\endgroup$ – Dimitris Oct 7 '15 at 13:44
  • 1
    $\begingroup$ @dimitris No,please.Going to post an answer in a few mins $\endgroup$ – Dr. belisarius Oct 7 '15 at 13:46
  • 1
    $\begingroup$ So the idea is to shift the curves left and right, so they assemble into one smooth curve? $\endgroup$ – LLlAMnYP Oct 7 '15 at 13:46
  • $\begingroup$ @belisariusisforth: Ok! Thanks in advance for your time! @ LLlAMnYP: Exactly. $\endgroup$ – Dimitris Oct 7 '15 at 13:48
18
$\begingroup$

Let's first make interpolations of the data:

data = {data91, data88, data85, data82, data79, data76, data73, 
   data70, data67, data64, data61, data58, data55, data52, data49};

ints = Interpolation /@ data;

Now define a routine that shifts the curves in the set above the 61 deg curve so that their left-most point touches the next curve (recursively, so that previous shifts are taken care of). For the curves below the 61 deg curve shift such that the right-most point touches its neighbor.

ClearAll[sol]
master = 11; (* position of the reference curve in the data list *)
sol[i_ /; i < master] := 
 sol[i] = m /. 
   Last@NMinimize[
         {
          EuclideanDistance[
            {data[[i, 1, 1]] + m, ints[[i]][data[[i, 1, 1]]]}, 
            {k + sol[i + 1]     , ints[[i + 1]][k]          }
          ], 
          data[[i + 1, 1, 1]] <= k <= data[[i + 1, -1, 1]]
        }, {{m, 0.1, 0.8}, {k, 0.1, 0.2}}
       ]
sol[i_ /; i > master] := 
 sol[i] = m /. 
   Last@NMinimize[
          {
            EuclideanDistance[
              {data[[i, -1, 1]] + m, ints[[i]][data[[i, -1, 1]]]}, 
              {k + sol[i - 1]      , ints[[i - 1]][k]           }
            ], 
            data[[i - 1, 1, 1]] <= k <= data[[i - 1, -1, 1]]
          }, {{m, 0.1, 0.8}, {k, 0.1, 0.2}}
        ]
sol[master] = 0;

Calculate all shifts:

shifts = sol /@ Range[Length@data]
(* {14.0704, 12.49, 11.0173, 9.66209, 8.18936, 6.57826, \
5.09644, 3.68002, 2.3482, 1.0713, 0, -1.14927, -2.02456, -2.89625, \
-3.65812} *)

Apply shifts:

dataShift = MapIndexed[Function[v, {#1, 0} + v] /@ data[[#2[[1]]]] &, shifts];

And plot:

temps = -{91, 88, 85, 82, 79, 76, 73, 70, 67, 64, 61, 58, 55, 52, 49};

ListLinePlot[dataShift, Frame -> True, 
 PlotRangePadding -> Scaled[0.1], Axes -> False, 
 PlotMarkers -> {{○, Medium}}, 
 PlotStyle -> Map[ColorData[{"Rainbow", {-91, -49}}], temps], 
 PlotLegends -> Quantity[temps, "DegreesCelsius"], ImageSize -> 600, 
 FrameLabel -> {"logω", 
   "E'(\!\(\*SubscriptBox[\(T\), \(0\)]\)/T)"}, 
 FrameStyle -> Directive[14], RotateLabel -> False]

Mathematica graphics

$\endgroup$
  • $\begingroup$ Damn. Beat me by a min :) +1. $\endgroup$ – Dr. belisarius Oct 7 '15 at 13:47
  • 1
    $\begingroup$ @belisariusisforth Good that I posted the code first and added comments later ;-P $\endgroup$ – Sjoerd C. de Vries Oct 7 '15 at 13:51
  • 1
    $\begingroup$ @belisariusisforth Not a simple and boring one with FindRoot or NSolve I hope? ;-) $\endgroup$ – Sjoerd C. de Vries Oct 7 '15 at 13:58
  • 2
    $\begingroup$ @SjoerdC.deVries nah, I was minimizing the Abs of the integral of the difference of the interpolating functions. It works, but it is too slow $\endgroup$ – Dr. belisarius Oct 7 '15 at 14:10
  • 2
    $\begingroup$ @bel The forth is strong in you $\endgroup$ – Sjoerd C. de Vries Oct 8 '15 at 16:15
13
$\begingroup$

As Sjoerd treacherously spoiled my answer I'm posting an interpolation (slower) version that spans a 10% larger domain:


Edit

The following replacement in the code below serves the same function and is much faster, but it exploits a geometric symmetry of your particular curves:

bestShift[{d1_List, d2_List}] :=(x /. FindRoot[superpos[d1, d2, x], {x, -1, -2, 0}, 
    AccuracyGoal -> 3])

data = {data91, data88, data85, data82, data79, data76, data73, 
   data70, data67, data64, data61, data58, data55, data52, data49};

dataS = SortBy[data, #[[1, 2]] &]; 
Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"]; 
superpos[d1_, d2_, x_?NumericQ] := 
 Module[{f1 = Interpolation@d1, f2 = Interpolation[{x, 0} + # & /@ d2], dom},
  dom = IntervalIntersection @@ ((Interval @@ 
                     InterpolatingFunctionDomain[#]) & /@ {f1, f2}) // First;
  Abs@NIntegrate[f1@y - f2@y, {y, dom[[1]], dom[[2]]}]
  ]

(* replace with the function in the edit above *)
bestShift[{d1_List, d2_List}] := (x /. 
                      Last@NMinimize[{superpos[d1, d2, x], -2 <= x <= 0}, x, 
                             AccuracyGoal -> 3, Method -> "SimulatedAnnealing"])

bs = bestShift /@ Partition[data, 2, 1]

(* we want data[[11]] not shifted *)

accBs = # - #[[11]] &@Join[{0}, Accumulate@bs]
(*
 {16.0986, 14.5014, 12.818, 11.1625, 9.38324, 7.5946, 5.87548, 
  4.19353, 2.58556, 1.19733, 0., -1.03404, -1.93369, -2.7309, -3.44727}
*)
MapThread[Function[{d, s}, {s, 0} + # & /@ d], {data, accBs}, 1] // ListLinePlot

Mathematica graphics

Then you can build a smooth interpolating function:

pts = Sort[Join @@ MapThread[Function[{d, s}, {s, 0} + # & /@ d], {data, accBs}, 1]];
smooth = Transpose[GaussianFilter[#, 5] & /@ Transpose@pts];
f = Interpolation[smooth];
dom = First@InterpolatingFunctionDomain@f;
Plot[f@x, {x, dom[[1]], dom[[2]]}]

Mathematica graphics

$\endgroup$
  • 1
    $\begingroup$ All this back and forth could take us sideways (e.g. Lie bracket !=0, so we can parallel park our cars). $\endgroup$ – Daniel Lichtblau Oct 7 '15 at 16:08
  • 3
    $\begingroup$ Hey, what took you so long? You used to be faster, hehe. +1 anyway $\endgroup$ – Sjoerd C. de Vries Oct 7 '15 at 19:00

Your Answer

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Not the answer you're looking for? Browse other questions tagged or ask your own question.