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.

Improve this question
$\endgroup$
5
  • 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$ Commented Oct 7, 2015 at 13:41
  • $\begingroup$ Should I delete the question? $\endgroup$ Commented Oct 7, 2015 at 13:44
  • 1
    $\begingroup$ @dimitris No,please.Going to post an answer in a few mins $\endgroup$ Commented Oct 7, 2015 at 13:46
  • 1
    $\begingroup$ So the idea is to shift the curves left and right, so they assemble into one smooth curve? $\endgroup$ Commented Oct 7, 2015 at 13:46
  • $\begingroup$ @belisariusisforth: Ok! Thanks in advance for your time! @ LLlAMnYP: Exactly. $\endgroup$ Commented Oct 7, 2015 at 13:48

3 Answers 3

Reset to default
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

Improve this answer
$\endgroup$
10
  • $\begingroup$ Damn. Beat me by a min :) +1. $\endgroup$ Commented Oct 7, 2015 at 13:47
  • 1
    $\begingroup$ @belisariusisforth Good that I posted the code first and added comments later ;-P $\endgroup$ Commented Oct 7, 2015 at 13:51
  • 1
    $\begingroup$ @belisariusisforth Not a simple and boring one with FindRoot or NSolve I hope? ;-) $\endgroup$ Commented Oct 7, 2015 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$ Commented Oct 7, 2015 at 14:10
  • 2
    $\begingroup$ @bel The forth is strong in you $\endgroup$ Commented Oct 8, 2015 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

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

i have data of thermomecanical .it is possible to introduire tts superposition principe to create master curve of creep by WLF equation and arrhensius

Improve this answer
$\endgroup$
2
  • $\begingroup$ If you have a new question, please ask it by clicking the Ask Question button. Include a link to this question if it helps provide context. - From Review $\endgroup$ Commented Nov 18, 2023 at 2:35
  • $\begingroup$ Welcome to the Mathematica Stack Exchange. Please include Mathematica code (and images, if helpful) to describe the challenge you face in a new post. While you are here, please don't forget to take the Site Tour and to visit the Help page. Thanks. $\endgroup$ Commented Nov 18, 2023 at 3:02

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.