Skip to main content

graphics - How to compute the Multifractal Spectrum of a Financial Series with WTMM


I would like to know if someone knows how to compute the Multifractal Spectrum of a Financial Time Series (Currency) througth the Wavelet Transformation Modulus Maxima (WTMM).


I would highly appreciate any hint in order to calculate Dq, Tau(q), alpha, f(alpha).


I am pasting here the code I am using to get the Multifractal Spectrum (Ref: Gerd Baumann - Mathematica for Theoretical Physics (Mathematica 6.0), Springer Second Edition (2005), page 892) Comments: The following code helps to get the MultiFractal Spectrum, with Mathematica 6.0. I have updated the function ListPlot to ListLinePlot and PlotJoined to Joined as suggested in the Help of Mathematica 8.0.


The code seems to work when the input are the probabilities pi ={p1,p2,....pn} and when the values of each subset of the probability space one is seeking to characterize.


The code doesn't work 100% and I still don't know why (I am new to Mathematica).


The thing is, that the package provided by Mr. Baumann works when you give the input of the probabilities - yet I need that such process should be automated by the WTMM so I can see (analyze) the Whole Multifractal Spectrum.


----------------- ## ----------------------------



BeginPackage["MultiFractal`"];
Clear[Dq, Tau, Alpha, MultiFractal];
MultiFractal::usage = "MultiFractal[p_List,r_List] calculates the 
        multifractal spectrum D_q for a model based on the probabilities
        p and the scaling factors r. This function plots five functions
        Tau(q), D_q(q), Alpha(q), f(q) and f(Alpha).";
Begin["Private`"];

(*---calculate the multifractal dimensions---*)
Dq[p_List, r_List] := Block[{l1, l2, listrg = {}},

   (*---length of the lists---*)
   l1 = Length[p]; l2 = Length[r];
   If[l1 == l2,
    (*---variation of q and determination of D_q---*)
    Do[gl1 = Sum[p[[j]]^q r[[j]]^((q - 1) Dfractal), {j, 1, l1}] - 1;
     result = FindRoot[gl1 == 0, {Dfractal, -3, 3}];
     result = -Dfractal /. result;
     (*---collect the result in a list----*)
     AppendTo[listrg, {q, result}], {q, -10, 10, .101}]
    ,

    Print[" "];
    Print["  Lengths of lists are different!"];
    listrg = {}];
   listrg];

(*----calculate Tau---*)
Tau[result_list] := Block[{l1, listtau = {}},
   (*----lengths of the lists---*)
   l1 = Length[result];
   (*---calcultate Tau---*)

   Do[AppendTo[
     listtau, {result[[k, 1]], 
      result[[k, 2]] (1 - result[[k, 1]])}], {k, 1, l1}];
   listtau];

(*---Legendre transform---*)
Alpha[result_List] := 
  Block[{l1, dq, listalpha = {}, listf = {}, listleg = {}, mlist = {},
     pl1, pl2},
   (*---lengths of the lists---*)

   l1 = Length[result];
   (*---determine the differential dq---*)
   dq = (result[[2, 1]] - result[[1, 1]]) 2;
   (*---calculate Alpha by numerical differentiation---*)
   Do[AppendTo[
     listalpha, {result[[k, 
        1]], (result[[k + 1, 2]] - result[[k - 1, 2]])/dq}], {k, 2, 
     l1 - 1}];
   l1 = Length[listalpha];
   (*---calculate f and collect the result in a list---*)

   Do[AppendTo[
     listf, {result[[k, 
        1]], -(result[[k, 1]] listalpha[[k, 2]] - result[[k, 2]])}];
    listalpha[[k, 2]] = -listalpha[[k, 2]], {k, 1, 12}];
   (*---list of the Legendre transforms---*)
   Do[AppendTo[listleg, {listalpha[[k, 2]], listf[[k, 2]]}]; 
    AppendTo[mlist, listf[[k, 2]]], {k, 1, l2}];
   (*---plot f and alpha versus q---*)
   pl1 = ListLinePlot[listalpha, Joined -> {True, False}, 
     AxesLabel -> {"q", "\[Alpha]"}, Prolog -> Thickness[0.001]];

   pl2 = ListLinePlot[listf, Joined -> {True, False}, 
     AxesLabel -> {"q", "f"}, Prolog -> Thickness[0.001]];
   Show[{pl1, pl2}, AxesLabel -> {"q", "\[Alpha],f"}];
   (*---plot the Legendre transform f versus alpha---*)
   ListLinePlot[listleg, AxesLabel -> {"\[Alpha]", "f"}];
   (*---print the maximum of f=D_ 0---*)
   maxi = Max[mlist];
   Print[" "];
   Print["   D_0 = ", maxi]];


(*---calcultate the multifractal properties---*)
MultiFractal[p_List, r_List] := Block[{listDq, listTau},
   (*---determine D_q---*)
   listDq = Dq[p, r];
   ListLinePlot[listDq, Joined -> {True, False}, 
      AxesLabel -> {"q", "Dq"}, Prolog -> Thickness[0.001]]
     (*---calculate Tau---*)
      listTau = Tau[listDq];
   ListLinePlot[listTau, Joined -> {True, False}, 
     AxesLabel -> {"q", "\[Tau]"}, Prolog -> Thickness[0.001]]

    (*---determine the Hoelder exponent---*) 
    Alpha[listTau]];

End[];

EndPackage[];

Answer



The code (Importation de la série)


ClearAll["Global`*"]
d = Import[SystemDialogInput["FileOpen"]];

ima = Flatten[d];
ima = ima + 0.000001;
n1 = Length[d];
n2 = Log[2, Length[ima]];
ny = Table[2^i, {i, 3, n2}];

(*Calcul des valeurs Dq pour chaque sous série*)

f[n_] := Module[{xx = ima, d2, stot, freqpuis, somfreqpuis, pq},
  d2 = Partition[xx, n];

  fmaxmin[x_List] := Mean[x];
  stot = Map[fmaxmin, d2] // N;
  stot = stot/Total[Flatten[stot]];
  freqpuis = Table[stot^j, {j, -7, 7, 0.5}];
  somfreqpuis = Total[Transpose[freqpuis]];
  pq = Log[2, somfreqpuis]
  ]

logmuql = Flatten[Table[f[i], {i, ny}]] // N;
logmuqlt = Partition[logmuql, 29];

pqpart = logmuqlt;
logtaille = Log[2, ny] // N;

f2[nn_] := 
 Module[{a = logtaille, b = logmuqlt, essai, line, linen, fa1},
  essai = Partition[Riffle[logtaille, logmuqlt[[All, nn]]], 2];
  line = LinearModelFit[essai, x, x];
  linen = Normal[line];
  fa1 = linen[[2, 1]] // N
  ]


Dq = Table[f2[i], {i, 1, 29}];
qq = Table[i, {i, -7, 7, 0.5}];
q = 1/(qq - 1.000001);
Dqq = q*Dq;
kq = 2 - Dqq;
cq = kq*q;
qmoin = qq - 1;
rq = qmoin*Dq;
ecartDq = Dqq[[1]] - Dqq[[29]] // N;

Print["ecart Dq = ", ecartDq]
ListPlot[{pqpart[[All, 1]], pqpart[[All, 5]], pqpart[[All, 10]], 
   pqpart[[All, 15]], pqpart[[All, 20]], pqpart[[All, 29]]}, 
 ImageSize -> {300, 200}, Joined -> True, 
 AxesLabel -> {"log_tailleboite", "SomPiQ"}, PlotRange -> All, 
 PlotStyle -> PointSize[Medium]]

dqrel = Dqq - 1;
d3 = Riffle[qq, Dqq];
d6 = Partition[d3, 2];

d6 = Drop[d6, {17}];

ListPlot[{d6}, 
  ImageSize -> {300, 200}, Joined -> True, 
  AxesLabel -> {"q", "Dq"}, PlotRange -> All, PlotStyle -> {Black}]

d3 = Riffle[qq, kq];
d6 = Partition[d3, 2];
d6 = Drop[d6, {17}];


ListPlot[{d6}, ImageSize -> {300, 200}, Joined -> True, 
 AxesLabel -> {"q", "Kq"}, PlotRange -> All, PlotStyle -> {Black}]

d3 = Riffle[qq, cq];
d6 = Partition[d3, 2];
d6 = Drop[d6, {17}];
ListPlot[{d6}, 
  ImageSize -> {300, 200}, Joined -> True, 
   AxesLabel -> {"q", "Cq"}, PlotRange -> All, PlotStyle -> {Black}]


d3 = Riffle[qmoin, rq];
d6 = Partition[d3, 2];
d6 = Drop[d6, {17}];
ListPlot[{d6}, 
 ImageSize -> {300, 200}, Joined -> True, 
 AxesLabel -> {"q", "Tauq"}, PlotRange -> All, PlotStyle -> {Black}]

d3 = Riffle[qq, dqrel];
d6 = Partition[d3, 2];
d6 = Drop[d6, {17}];

ListPlot[{d6}, 
  ImageSize -> {300, 200}, Joined -> True, 
  AxesLabel -> {"q", "Dq_Relatif"}, PlotRange -> All, 
  PlotStyle -> {Black}]

fo[n_] := 
  Module[{xx = ima, d2, stot, tfreqpuis, freqpuis, logfreqpuis, 
    produitfreq, somfproduit4},
  d2 = Partition[xx, n];
  fmaxmin[x_List] := Mean[x];

  stot = Map[fmaxmin, d2] // N;
  freqpuis = Table[stot^j, {j, -7, 7, 0.5}];
  tfreqpuis = Total[Transpose[freqpuis]];
  freqpuis = freqpuis/tfreqpuis;
  logfreqpuis = Log[10, freqpuis];
  produitfreq = freqpuis*logfreqpuis;
  somfproduit4 = Map[Total, produitfreq] // N
  ]

totlogmuql = Flatten[Table[fo[i], {i, ny}]];

logmuqlt = Partition[totlogmuql, 29];
pqpart = logmuqlt;
logtaille = Log[10, ny] // N;

fo2[nn_] := 
 Module[{a = logtaille, b = logmuqlt, essai, line, linen, fa1},
  essai = Partition[Riffle[logtaille, logmuqlt[[All, nn]]], 2];
  line = LinearModelFit[essai, x, x];
  linen = Normal[line];
  fa1 = ToExpression[linen[[2, 1]]] // N

  ]

fqr = Table[fo2[i], {i, 1, 29}];
qq = Table[i, {i, -7, 7, 0.5}];
fq2 = Riffle[qq, fqr];
fq2 = Partition[fq2, 2];

ListPlot[{fq2}, 
  ImageSize -> {300, 200}, Joined -> True, 
  AxesLabel -> {"q", "f(alpha)q"}, PlotRange -> All, 

  PlotStyle -> {Black}]
ecartFq = fqr[[29]] - fqr[[1]] // N;
Print["ecart Fq = ", ecartFq]

Comments

Post a Comment

Popular posts from this blog

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...
Post a Comment
Read more

list manipulation - Selecting multiple columns from a matrix?

Sample data: data = { {{2013, 1, 1}, 24.13, 167.67, 231.82}, {{2013, 1, 2}, 32.15, 170.92, 225.99}, {{2013, 1, 3}, 35.43, 172.68, 221.67}, {{2013, 1, 4}, 36.73, 173.05, 218.32}, {{2013, 1, 5}, 58.19, 165.96, 197.05}, {{2013, 1, 6}, 69.99, 163.50, 187.52}, {{2013, 1, 7}, 71.37, 154.21, 175.58}, {{2013, 1, 8}, 72.51, 149.66, 163.25}}; I want a DateListPlot with three graphs, so for a matrix formed by columns 1 and 2, one for columns 1 and 3, and 1 for columns 1 and 4. At the moment I'm using this code: data2 = Transpose[{data[[All, 1]], data[[All, 2]]}]; data3 = Transpose[{data[[All, 1]], data[[All, 3]]}]; data4 = Transpose[{data[[All, 1]], data[[All, 4]]}]; DateListPlot[{data2, data3, data4}, Joined -> True, Filling -> {3 -> {1}}] but I have a hunch that this can be done more efficiently. I don't like the Transpose s in particular. Any ideas? edit (for extra credit) What if I need to multiply the second column by 2, which in my solution is simp...
Post a Comment
Read more

calculus and analysis - Integral of the Sinc product

Let us consider the following integral $$ B_n = \int_0^\infty \prod_{k=1,3,5,\dots}^n\frac{\sin (x/k)}{x/k}dx $$ By definition, Sinc[x] == Sin[x]/x , therefore B[n_?OddQ] := Integrate[Product[Sinc[x/k], {k, 1, n, 2}], {x, 0, Infinity}] B /@ Range[1, 13, 2] {Pi/2, Pi/2, Pi/2, Pi/2, Pi/2, Pi/2, Pi/2} OK, everything is fine. But... B[15] 467807924713440738696537864469 Pi/935615849440640907310521750000 What's going on? Answer As Eckhard wrote in comments B[n] is the n-th Borwein integral . (The letter B was not accidental :) ) This funny properties of Borwein integrals is related to the Fourier transform of Sinc function FourierTransform[Sinc[x], x, k] 1/2 Sqrt[Pi/2] (Sign[1 - k] + Sign[1 + k]) Plot[%, {k, -2, 2}, Filling -> 0] which is the box function. The result is $\pi/2$ while the sum $$ 1/3+1/5+\dots+1/n $$ B_n = \frac{\pi}{2} - \pi \bigg(\sum_{k=3,5,\ldots}^n\frac{1}{k} -1\biggr)^\frac{n-1}{2}\prod_{k=3,5,\dots}^n\frac{k}{k-1}. $$ For $n=15$ it is equal to $$ \frac{46780...
Post a Comment
Read more