# 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[];

-
Welcome to Mathematica SE! Your question (as it is) seems to be more suitable for the Mathematics SE. If you want to know how to use Wolfram Mathematica to compute multifractal spectra please help us by adding a minimal working code example or anything that shows us your progress. – jens_bo Aug 19 '13 at 4:01
Thank you Jenson, I have added the code editing the initial comment (so to save space - hope it's ok with the Virtual Space Policies). – smuller Aug 19 '13 at 12:18

The code (Importation de la série)

ClearAll["Global*"]
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]
`
-
Thank you @Dauphine so much bests! – smuller Aug 20 '13 at 3:21
Dear @Dauphine, I have run your code, yet I found a lot of 'errors' in my Mathematica 8.0 (could that be?), any idea what might be different? – smuller Aug 20 '13 at 3:50
These are some of the errors that I get: Set::write: Tag Times in d Null is Protected. >> Flatten::normal: Nonatomic expression expected at position 1 in Flatten[d]. >> Partition::pdep: Depth 1 requested in object with dimensions {}. >> ecart Dq = -0.291667 Dq Part::partd: Part specification Partition[logmuql,29][[All,1]] is longer than depth of object. >> Part::partd: Part specification Partition[logmuql,29][[All,5]] is longer than depth of object. >> Part::partd: Part specification Partition[logmuql,29][[All,10]] is longer than depth of object. >> – smuller Aug 20 '13 at 3:54
in f2[nn_] theres is a ";" missing in the line "fa1 = linen[[2, 1]] // N ] Dq = Table[f2[i], {i, 1, 29}];" --> or it is ok without ";"? - I highly appreciate your help, thank you. – smuller Aug 20 '13 at 4:01
@m_goldberg thank you so much for correcting the code. Now it works. Thank you very very much! – smuller Aug 30 '13 at 13:26