While looking at the belisarius's question about generation of non-singular integer matrices with uniform distribution of its elements, I was studying a paper by Dana Randal, "Efficient generation of random non-singular matrices". The algorithm proposed is recursive, and involves generating a matrix of lower dimension and assigning it to a given minor. I used combinations of Insert and Transpose to do it, but there are must be more efficient ways of doing it. How would you do it?
The following is the code:
Clear[Gen];
Gen[p_, 1] := {{{1}}, RandomInteger[{1, p - 1}, {1, 1}]};
Gen[p_, n_] := Module[{v, r, aa, tt, afr, am, tm},
While[True,
v = RandomInteger[{0, p - 1}, n];
r = LengthWhile[v, # == 0 &] + 1;
If[r <= n, Break[]]
];
afr = UnitVector[n, r];
{am, tm} = Gen[p, n - 1];
{Insert[
Transpose[
Insert[Transpose[am], RandomInteger[{0, p - 1}, n - 1], r]], afr,
1], Insert[
Transpose[Insert[Transpose[tm], ConstantArray[0, n - 1], r]], v,
r]}
]
NonSingularRandomMatrix[p_?PrimeQ, n_] := Mod[Dot ## Gen[p, n], p]
It does generate a non-singular matrix, and has uniform distribution of matrix elements, but requires p to be prime:
The code is also not every efficient, which is, I suspect due to my inefficient matrix constructors:
In[10]:= Timing[NonSingularRandomMatrix[101, 300];]
Out[10]= {0.421, Null}
EDIT So let me condense my question. The minor matrix of a given matrix m can be computed as follows:
MinorMatrix[m_?MatrixQ, {i_, j_}] :=
Drop[Transpose[Drop[Transpose[m], {j}]], {i}]
It is the original matrix with i-th row and j-th column deleted.
I now need to create a matrix of size n by n that will have the given minor matrix mm at position {i,j}. What I used in the algorithm was:
ExpandMinor[minmat_, {i_, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[minmat] :=
Insert[Transpose[Insert[Transpose[minmat], v2, j]], v1, i]
Example:
In[31]:= ExpandMinor[
IdentityMatrix[4], {2, 3}, {1, 2, 3, 4, 5}, {2, 3, 4, 4}]
Out[31]= {{1, 0, 2, 0, 0}, {1, 2, 3, 4, 5}, {0, 1, 3, 0, 0}, {0, 0, 4,
1, 0}, {0, 0, 4, 0, 1}}
I am hoping this can be done more efficiently, which is what I am soliciting in the question.
Per blisarius's suggestion I looked into implementing ExpandMinor via ArrayFlatten.
Clear[ExpandMinorAlt];
ExpandMinorAlt[m_, {i_ /; i > 1, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[m] :=
ArrayFlatten[{
{Part[m, ;; i - 1, ;; j - 1], Transpose#{v2[[;; i - 1]]},
Part[m, ;; i - 1, j ;;]},
{{v1[[;; j - 1]]}, {{v1[[j]]}}, {v1[[j + 1 ;;]]}},
{Part[m, i ;;, ;; j - 1], Transpose#{v2[[i ;;]]}, Part[m, i ;;, j ;;]}
}]
ExpandMinorAlt[m_, {1, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[m] :=
ArrayFlatten[{
{{v1[[;; j - 1]]}, {{v1[[j]]}}, {v1[[j + 1 ;;]]}},
{Part[m, All, ;; j - 1], Transpose#{v2}, Part[m, All, j ;;]}
}]
In[192]:= dim = 5;
mm = RandomInteger[{-5, 5}, {dim, dim}];
v1 = RandomInteger[{-5, 5}, dim + 1];
v2 = RandomInteger[{-5, 5}, dim];
In[196]:=
Table[ExpandMinor[mm, {i, j}, v1, v2] ==
ExpandMinorAlt[mm, {i, j}, v1, v2], {i, dim}, {j, dim}] //
Flatten // DeleteDuplicates
Out[196]= {True}
It took me a while to get here, but since I spent a good part of my postdoc generating random matrices, I could not help it, so here goes. The main inefficiency in the code comes from the necessity to move matrices around (copy them). If we could reformulate the algorithm so that we only modify a single matrix in place, we could win big. For this, we must compute the positions where the inserted vectors/rows will end up, given that we will typically insert in the middle of smaller matrices and thus shift the elements. This is possible. Here is the code:
gen = Compile[{{p, _Integer}, {n, _Integer}},
Module[{vmat = Table[0, {n}, {n}],
rs = Table[0, {n}],(* A vector of r-s*)
amatr = Table[0, {n}, {n}],
tmatr = Table[0, {n}, {n}],
i = 1,
v = Table[0, {n}],
r = n + 1,
rsc = Table[0, {n}], (* recomputed r-s *)
matstarts = Table[0, {n}], (* Horizontal positions of submatrix starts at a given step *)
remainingShifts = Table[0, {n}]
(*
** shifts that will be performed after a given row/vector insertion,
** and can affect the real positions where the elements will end up
*)
},
(*
** Compute the r-s and vectors v all at once. Pad smaller
** vectors v with zeros to fill a rectangular matrix
*)
For[i = 1, i <= n, i++,
While[True,
v = RandomInteger[{0, p - 1}, i];
For[r = 1, r <= i && v[[r]] == 0, r++];
If[r <= i,
vmat[[i]] = PadRight[v, n];
rs[[i]] = r;
Break[]]
]];
(*
** We must recompute the actual r-s, since the elements will
** move due to subsequent column insertions.
** The code below repeatedly adds shifts to the
** r-s on the left, resulting from insertions on the right.
** For example, if vector of r-s
** is {1,2,1,3}, it will become {1,2,1,3}->{2,3,1,3}->{2,4,1,3},
** and the end result shows where
** in the actual matrix the columns (and also rows for the case of
** tmatr) will be inserted
*)
rsc = rs;
For[i = 2, i <= n, i++,
remainingShifts = Take[rsc, i - 1];
For[r = 1, r <= i - 1, r++,
If[remainingShifts[[r]] == rsc[[i]],
Break[]
]
];
If[ r <= n,
rsc[[;; i - 1]] += UnitStep[rsc[[;; i - 1]] - rsc[[i]]]
]
];
(*
** Compute the starting left positions of sub-
** matrices at each step (1x1,2x2,etc)
*)
matstarts = FoldList[Min, First#rsc, Rest#rsc];
(* Initialize matrices - this replaces the recursion base *)
amatr[[n, rsc[[1]]]] = 1;
tmatr[[rsc[[1]], rsc[[1]]]] = RandomInteger[{1, p - 1}];
(* Repeatedly perform insertions - this replaces recursion *)
For[i = 2, i <= n, i++,
amatr[[n - i + 2 ;; n, rsc[[i]]]] = RandomInteger[{0, p - 1}, i - 1];
amatr[[n - i + 1, rsc[[i]]]] = 1;
tmatr[[n - i + 2 ;; n, rsc[[i]]]] = Table[0, {i - 1}];
tmatr[[rsc[[i]],
Fold[# + 1 - Unitize[# - #2] &,
matstarts[[i]] + Range[0, i - 1], Sort[Drop[rsc, i]]]]] =
vmat[[i, 1 ;; i]];
];
{amatr, tmatr}
],
{{FoldList[__], _Integer, 1}}, CompilationTarget -> "C"];
NonSignularRanomMatrix[p_?PrimeQ, n_] := Mod[Dot ## Gen[p, n],p];
NonSignularRanomMatrixAlt[p_?PrimeQ, n_] := Mod[Dot ## gen[p, n],p];
Here is the timing for the large matrix:
In[1114]:= gen [101, 300]; // Timing
Out[1114]= {0.078, Null}
For the histogram, I get the identical plots, and the 10-fold efficiency boost:
In[1118]:=
Histogram[Table[NonSignularRanomMatrix[11, 5][[2, 3]], {10^4}]]; // Timing
Out[1118]= {7.75, Null}
In[1119]:=
Histogram[Table[NonSignularRanomMatrixAlt[11, 5][[2, 3]], {10^4}]]; // Timing
Out[1119]= {0.687, Null}
I expect that upon careful profiling of the above compiled code, one could further improve the performance. Also, I did not use runtime Listable attribute in Compile, while this should be possible. It may also be that the parts of the code which perform assignment to minors are generic enough so that the logic can be factored out of the main function - I did not investigate that yet.
For the first part of your question (which I hope I understand properly) can
MinorMatrix be written as follows?
MinorMatrixAlt[m_?MatrixQ, {i_, j_}] := Drop[mat, {i}, {j}]
Related
I am trying to increase the size of matrix below through for loop but the code gives an error that I have not found a solution until this point. Here is my code,
m = 1;
n = 1;
mat2 = Table[0, {m}, {n}];
For[i = 1, i <= n + 1, i++,
For[j = 1, j <= m + 1, j++,
mat2[[i, j]] = j
];
];
mat2 // MatrixForm
How can I solve this problem?
In[1]:= m = 2; n = 2; mat2 = Table[i + j, {i, m}, {j, n}];
mat2 = ArrayPad[mat2, {0, 1}];
mat2 // MatrixForm
Out[3]//MatrixForm=
{{2, 3, 0},
{3, 4, 0},
{0, 0, 0}}
a neat little trick using SparseArray ..
mat = SparseArray[Table[1, {5}, {5}]]
mat = SparseArray[Prepend[ArrayRules[mat], {6, 8} -> 9]]
note this copies the entire array to a new larger array (as does ArrayPad ), so you really don't want to be doing this often for large arrays.
likewise an "assignment" into an existing position works, but you don't want to do this for performance reasons:
mat = SparseArray[Prepend[ArrayRules[mat], {2, 2} -> 3]]
rather than growing arrays you would be better off to define a sufficiently large SparseArray in the first place (there is little/no memory hit for making a huge empty SparseArray)
mat = SparseArray[Table[1, {5}, {5}], {1000, 1000}];
mat[[6, 8]] = 9;
mat[[2, 2]] = 3;
(just don't try to print this..)
when done save the non-empty part:
mat=SparseArray[ArrayRules[mat]]
let n be an integer and A = {2,3,...,10} and I want to do as follows:
divide n to 2, so there is a reminder r2 and a quotient q2.
divide q2 to 3, so there is a reminder r3 and a quotient q3.
we repeat this until the quotient is less than the next number.
write together the last quotient with the previous reminders.
For example n=45
45/2 ....... r_2=1, q_2=22
22/3 ....... r_3=1, q_3=7
7/4 ....... r_4=3, q_4=1
since q4 = 1 is less than the next number i.e. 5, we break.
the result is q4r4r3r2 where it is equal to 1311.
Thank you for your help.
I did this but it does not work
n = 45;
i = 2;
list = {Mod[n, i]};
While[Quotient[n, i] >= i + 1, n == Quotient[n, i]; i++;
AppendTo[list, Mod[n, i]];
If[Quotient[n, i] < i + 1, Break[]]; AppendTo[list, Quotient[n, i]]];
list
Row[Reverse[list]]
which gives
{1, 0, 15, 1, 11, 0, 9, 3, 7, 3}
Row[{3, 7, 3, 9, 0, 11, 1, 15, 0, 1}]
where it is not my desired result.
This is the code:
A = Table[i, {i, 2, 10}]; (* array of numbers *)
n = 45; (* initial value *)
ans = {}; (* future answer which is now empty list *)
For[i = 1, i <= Length[A], i++, (* looping over A *)
If[n < A[[i]], (* exit condition *)
ans = Append[ans, n]; (* appending last n when exit *)
Break[]
];
qr = QuotientRemainder[n, A[[i]]]; (* calculating both quotient and reminder *)
ans = Append[ans, qr[[2]]]; (* adding second member to the answer *)
Print[qr]; (* printing *)
n = qr[[1]]; (* using first member as new n to process *)
];
ans (* printing result in Mathematica manner *)
It gives
{1, 1, 3, 1}
You might use something like this:
f[n_Integer] :=
NestWhileList[
{QuotientRemainder[#[[1, 1]], #[[2]] + 1], #[[2]] + 1} &,
{{n}, 1},
#[[1, 1]] != 0 &
] // Rest
f[45]
{{{22, 1}, 2}, {{7, 1}, 3}, {{1, 3}, 4}, {{0, 1}, 5}}
You can use Part to get whatever bits of the output you desire.
Here's a somewhat more advanced way if you can handle the syntax:
f2[n_Integer] := Reap[f2[{n, 0}, 2]][[2, 1, 2 ;;]] // Reverse
f2[{q_, r_}, i_] := f2[Sow # r; QuotientRemainder[q, i], i + 1]
f2[{0, r_}, i_] := Sow # r
f2[45]
{1, 3, 1, 1}
I'm looking for a way to reduce the length of a huge list with the Total function and a threshold parameter. I would like to avoid the use of For and If (coming from old habits).
Example :
List that I want to "reduce" :{1,5,3,8,11,3,4} with a threshold of 5.
Output that I want : {6,11,11,7}
That means that I use the Total function on the first parts of the list and look if the result of this function is higher than my threshold. If so, I use the result of the Total function and go to the next part of the list.
Another example is {1,1,1,1,1} with a threshold of 5. Result should be {5}.
Thanks!
EDIT : it is working but it is pretty slow. Any ideas in order to be faster?
EDIT 2 : the loop stuff (quit simple and not smart)
For[i = 1, i < Length[mylist] + 1, i++,
sum = sum + mylist[[i]];
If[sum > Threshold ,
result = Append[result , sum]; sum = 0; ]; ];
EDIT 3 : I have now a new thing to do.
I have to work now with a 2D list like {{1,2}{4,9}{1,3}{0,5}{7,3}}
It is more or less the same idea but the 1st and 2nd part of the list have to be higher than the thresold stuff (both of them).
Example : If lst[[1]] and lst[[2]] > threshold do the summuation for each part of the 2D list. I tried to adapt the f2 function from Mr.Wizard for this case but I didn't succeed. If it is easier, I can provide 2 independant lists and work with this input f3[lst1_,lst2_,thres_]:=
Reap[Sow#Fold[If[Element of the lst1 > thr && Element of the lst2, Sow##; #2, # + #2] &, 0, lst1]][[2, 1]] for example.
EDIT 4 :
You are right, it is not really clear. But the use of the Min## > thr statement is working perfectly.
Old code (ugly and not smart at all):
sumP = 0;
resP = {};
sumU = 0;
resU = {};
For[i = 1, i < Length[list1 + 1, i++,
sumP = sumP + list1[[i]];
sumU = sumU + list2[[i]];
If[sumP > 5 && sumU > 5 ,
resP = Append[resP, sumP]; sumP = 0;
resU = Append[resU, sumU]; sumU = 0;
];
]
NEW fast by Mr.Wizard :
f6[lst_, thr_] :=
Reap[Sow#Fold[If[Min## > thr , Sow##1; #2, #1 + #2] &, 0, lst]][[2,
1]]
That ~40times faster. Thanks a lot.
Thread[{resP, resU}] == f6[Thread[{list1,list2}], 5] True
I recommend using Fold for this kind of operation, combined with either linked lists or Sow and Reap to accumulate results. Append is slow because lists in Mathematica are arrays and must be reallocated every time an element is appended.
Starting with:
lst = {2, 6, 4, 4, 1, 3, 1, 2, 4, 1, 2, 4, 0, 7, 4};
Here is the linked-list version:
Flatten # Fold[If[Last## > 5, {#, #2}, {First##, Last## + #2}] &, {{}, 0}, lst]
{8, 8, 7, 7, 11, 4}
This is what the output looks like before Flatten:
{{{{{{{}, 8}, 8}, 7}, 7}, 11}, 4}
Here is the method using Sow and Reap:
Reap[Sow # Fold[If[# > 5, Sow##; #2, # + #2] &, 0, lst]][[2, 1]]
{8, 8, 7, 7, 11, 4}
A similar method applied to other problems: (1) (2)
The Sow # on the outside of Fold effectively appends the last element of the sequence which would otherwise be dropped by the algorithm.
Here are the methods packaged as functions, along with george's for easy comparison:
f1[lst_, thr_] :=
Flatten # Fold[If[Last## > thr, {#, #2}, {First##, Last## + #2}] &, {{}, 0}, lst]
f2[lst_, thr_] :=
Reap[Sow#Fold[If[# > thr, Sow##; #2, # + #2] &, 0, lst]][[2, 1]]
george[t_, thresh_] := Module[{i = 0, s},
Reap[While[i < Length[t], s = 0;
While[++i <= Length[t] && (s += t[[i]]) < thresh]; Sow[s]]][[2, 1]]
]
Timings:
big = RandomInteger[9, 500000];
george[big, 5] // Timing // First
1.279
f1[big, 5] // Timing // First
f2[big, 5] // Timing // First
0.593
0.468
Here is the obvious approach which is oh 300x faster.. Pretty isn't always best.
t = Random[Integer, 10] & /# Range[2000];
threshold = 4;
Timing[
i = 0;
t0 = Reap[
While[i < Length[t], s = 0;
While[++i <= Length[t] && (s += t[[i]]) < threshold ];
Sow[s]]][[2, 1]]][[1]]
Total[t] == Total[t0]
Timing[ t1 =
t //. {a___, b_ /; b < threshold, c_, d___} -> {a, b + c, d} ][[1]]
t1 == t0
I interpret your requirement as:
if an element in the list is less than the threshold value, add it to the next element in the list;
repeat this process until the list no longer changes.
So, for the threshold 5 and the input list {1,5,3,8,11,3,4} you'ld get
{6,3,8,11,3,4}
{6,11,11,3,4}
{6,11,11,7}
EDIT
I've now tested this solution to your problem ...
Implement the operation by using a replacement rule:
myList = {1,5,3,8,11,3,4}
threshold = 5
mylist = mylist //. {a___, b_ /; b < threshold, c_, d___} :> {a, b+c, d}
Note the use of ReplaceRepeated (symbolification //.).
Currently I am working with some Mathematica code to do a Picard Iteration. The code itself works fine but I am trying to make it more efficient. I have had some success but am looking for suggestions. It may not be possible to speed it up anymore but I have run out of ideas and am hoping people with more experience with programming/Mathematica than me might be able to make some suggestions. I am only posting the Iteration itself but can supply additional information as needed.
The code below was edited to be a fully executable as requested
Also I changed it from a While to a Do loop to make testing easier as convergence is not required.
Clear["Global`*"]
ngrid = 2048;
delr = 4/100;
delk = \[Pi]/delr/ngrid;
rvalues = Table[(i - 1/2) delr, {i, 1, ngrid}];
kvalues = Table[(i - 1/2) delk, {i, 1, ngrid}];
wa[x_] := (19 + .5 x) Exp[-.7 x] + 1
wb[x_] := (19 + .1 x) Exp[-.2 x] + 1
wd = SetPrecision[
Table[{{wa[(i - 1/2) delk], 0}, {0, wb[(i - 1/2) delk]}}, {i, 1,
ngrid}], 26];
sigmaAA = 1;
hcloseAA = {};
i = 1;
While[(i - 1/2)*delr < sigmaAA, hcloseAA = Append[hcloseAA, -1]; i++]
hcloselenAA = Length[hcloseAA];
hcloseAB = hcloseAA;
hcloselenAB = hcloselenAA;
hcloseBB = hcloseAA;
hcloselenBB = hcloselenAA;
ccloseAA = {};
i = ngrid;
While[(i - 1/2)*delr >= sigmaAA, ccloseAA = Append[ccloseAA, 0]; i--]
ccloselenAA = Length[ccloseAA];
ccloselenAA = Length[ccloseAA];
ccloseAB = ccloseAA;
ccloselenAB = ccloselenAA;
ccloseBB = ccloseAA;
ccloselenBB = ccloselenAA;
na = 20;
nb = 20;
pa = 27/(1000 \[Pi]);
pb = 27/(1000 \[Pi]);
p = {{na pa, 0}, {0, nb pb}};
id = {{1, 0}, {0, 1}};
AFD = 1;
AFDList = {};
timelist = {};
gammainitial = Table[{{0, 0}, {0, 0}}, {ngrid}];
gammafirst = gammainitial;
step = 1;
tol = 10^-7;
old = 95/100;
new = 1 - old;
Do[
t = AbsoluteTime[];
extractgAA = Table[Extract[gammafirst, {i, 1, 1}], {i, hcloselenAA}];
extractgBB = Table[Extract[gammafirst, {i, 2, 2}], {i, hcloselenBB}];
extractgAB = Table[Extract[gammafirst, {i, 1, 2}], {i, hcloselenAB}];
csolutionAA = (Join[hcloseAA - extractgAA, ccloseAA]) rvalues;
csolutionBB = (Join[hcloseBB - extractgBB, ccloseBB]) rvalues;
csolutionAB = (Join[hcloseAB - extractgAB, ccloseAB]) rvalues;
chatAA = FourierDST[SetPrecision[csolutionAA, 32], 4];
chatBB = FourierDST[SetPrecision[csolutionBB, 32], 4];
chatAB = FourierDST[SetPrecision[csolutionAB, 32], 4];
chatmatrix =
2 \[Pi] delr Sqrt[2*ngrid]*
Transpose[{Transpose[{chatAA, chatAB}],
Transpose[{chatAB, chatBB}]}]/kvalues;
gammahat =
Table[(wd[[i]].chatmatrix[[i]].(Inverse[
id - p.wd[[i]].chatmatrix[[i]]]).wd[[i]] -
chatmatrix[[i]]) kvalues[[i]], {i, ngrid}];
gammaAA =
FourierDST[SetPrecision[Table[gammahat[[i, 1, 1]], {i, ngrid}], 32],
4];
gammaBB =
FourierDST[SetPrecision[Table[gammahat[[i, 2, 2]], {i, ngrid}], 32],
4];
gammaAB =
FourierDST[SetPrecision[Table[gammahat[[i, 1, 2]], {i, ngrid}], 32],
4];
gammasecond =
Transpose[{Transpose[{gammaAA, gammaAB}],
Transpose[{gammaAB, gammaBB}]}]/(rvalues 2 \[Pi] delr Sqrt[
2*ngrid]);
AFD = Sqrt[
1/ngrid Sum[((gammafirst[[i, 1, 1]] -
gammasecond[[i, 1, 1]])/(gammafirst[[i, 1, 1]] +
gammasecond[[i, 1, 1]]))^2 + ((gammafirst[[i, 2, 2]] -
gammasecond[[i, 2, 2]])/(gammafirst[[i, 2, 2]] +
gammasecond[[i, 2, 2]]))^2 + ((gammafirst[[i, 1, 2]] -
gammasecond[[i, 1, 2]])/(gammafirst[[i, 1, 2]] +
gammasecond[[i, 1, 2]]))^2 + ((gammafirst[[i, 2, 1]] -
gammasecond[[i, 2, 1]])/(gammafirst[[i, 2, 1]] +
gammasecond[[i, 2, 1]]))^2, {i, 1, ngrid}]];
gammafirst = old gammafirst + new gammasecond;
time2 = AbsoluteTime[] - t;
timelist = Append[timelist, time2], {1}]
Print["Mean time per calculation = ", Mean[timelist]]
Print["STD time per calculation = ", StandardDeviation[timelist]]
Just some notes on things
ngrid,delr, delk, rvalues, kvalues are just the values used in making the problem discrete. Typically they are
ngrid = 2048;
delr = 4/100;
delk = \[Pi]/delr/ngrid;
rvalues = Table[(i - 1/2) delr, {i, 1, ngrid}];
kvalues = Table[(i - 1/2) delk, {i, 1, ngrid}];
All matrices being used are 2 x 2 with identical off-diagonals
The identity matrix and the P matrix(it is actually for the density) are
p = {{na pa, 0}, {0, nb pb}};
id = {{1, 0}, {0, 1}};
The major slow spots in the calculation I have identified are the FourierDST calculations (the forward and back transforms account for close to 40% of the calculation time) The gammahat calculation accounts for 40% of the time with the remaining time dominated by the AFD calculation.)
On my i7 Processor the average calculation time per cycle is 1.52 seconds. My hope is to get it under a second but that may not be possible.
My hope had been to introduce some parallel computation this was tried with both ParallelTable commands as well as using the ParallelSubmit WaitAll. However, I found that any speedup from the parallel calculation was offset by the communication time from the Master Kernel to the the other Kernels.(at least that is my assumption as calculations on new data takes twice as long as just recalculating the existing data. I assumed this meant that the slowdown was in disseminating the new lists) I played around with DistributDefinitions as well as SetSharedVariable, however, was unable to get that to do anything.
One thing I am wondering is if using Table for doing my discrete calculations is the best way to do this?
I had also thought I could possibly rewrite this in such a manner as to be able to compile it but my understanding is that only will work if you are dealing with machine precision where I am needing to working with higher precision to get convergence.
Thank you in advance for any suggestions.
I will wait for the code acl suggests, but off the top, I suspect that this construct:
Table[Extract[gammafirst, {i, 1, 1}], {i, hcloselenAA}]
may be written, and will execute faster, as:
gammafirst[[hcloselenAA, 1, 1]]
But I am forced to guess the shape of your data.
In the several lines using:
FourierDST[SetPrecision[Table[gammahat[[i, 1, 1]], {i, ngrid}], 32], 4];
you could remove the Table:
FourierDST[SetPrecision[gammahat[[All, 1, 1]], 32], 4];
And, if you really, really need this SetPrecision, couldn't you do it at once in the calculation of gammahat?
AFAI can see, all numbers used in the calculations of gammahat are exact. This may be on purpose but it is slow. You might consider using approximate numbers instead.
EDIT
With the complete code in your latest edit just adding an //N to your 2nd and 3rd line cuts timing at least in half without reducing numerical accuracy much. If I compare all the numbers in res={gammafirst, gammasecond, AFD} the difference between the original and with //N added is res1 - res2 // Flatten // Total ==> 1.88267*10^-13
Removing all the SetPrecision stuff speeds up the code by a factor of 7 and the results seem to be of similar accuracy.
I am wondering if anyone can help me to plot the Cantor dust on the plane in Mathematica. This is linked to the Cantor set.
Thanks a lot.
EDIT
I actually wanted to have something like this:
Here's a naive and probably not very optimized way of reproducing the graphics for the ternary Cantor set construction:
cantorRule = Line[{{a_, n_}, {b_, n_}}] :>
With[{d = b - a, np = n - .1},
{Line[{{a, np}, {a + d/3, np}}], Line[{{b - d/3, np}, {b, np}}]}]
Graphics[{CapForm["Butt"], Thickness[.05],
Flatten#NestList[#/.cantorRule&, Line[{{0., 0}, {1., 0}}], 6]}]
To make Cantor dust using the same replacement rules, we take the result at a particular level, e.g. 4:
dust4=Flatten#Nest[#/.cantorRule&,Line[{{0.,0},{1.,0}}],4]/.Line[{{a_,_},{b_,_}}]:>{a,b}
and take tuples of it
dust4 = Transpose /# Tuples[dust4, 2];
Then we just plot the rectangles
Graphics[Rectangle ### dust4]
Edit: Cantor dust + squares
Changed specs -> New, but similar, solution (still not optimized).
Set n to be a positive integer and choice any subset of 1,...,n then
n = 3; choice = {1, 3};
CanDChoice = c:CanD[__]/;Length[c]===n :> CanD[c[[choice]]];
splitRange = {a_, b_} :> With[{d = (b - a + 0.)/n},
CanD##NestList[# + d &, {a, a + d}, n - 1]];
cantLevToRect[lev_]:=Rectangle###(Transpose/#Tuples[{lev}/.CanD->Sequence,2])
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 4] // Rest;
Graphics[{FaceForm[LightGray], EdgeForm[Black],
Table[cantLevToRect[lev], {lev, Most#dust}],
FaceForm[Black], cantLevToRect[Last#dust /. CanDChoice]}]
Here's the graphics for
n = 7; choice = {1, 2, 4, 6, 7};
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 2] // Rest;
and everything else the same:
Once can use the following approach. Define cantor function:
cantorF[r:(0|1)] = r;
cantorF[r_Rational /; 0 < r < 1] :=
Module[{digs, scale}, {digs, scale} = RealDigits[r, 3];
If[! FreeQ[digs, 1],
digs = Append[TakeWhile[Most[digs]~Join~Last[digs], # != 1 &], 1];];
FromDigits[{digs, scale}, 2]]
Then form the dust by computing differences of F[n/3^k]-F[(n+1/2)/3^k]:
With[{k = 4},
Outer[Times, #, #] &[
Table[(cantorF[(n + 1/2)/3^k] - cantorF[(n)/3^k]), {n, 0,
3^k - 1}]]] // ArrayPlot
I like recursive functions, so
cantor[size_, n_][pt_] :=
With[{s = size/3, ct = cantor[size/3, n - 1]},
{ct[pt], ct[pt + {2 s, 0}], ct[pt + {0, 2 s}], ct[pt + {2 s, 2 s}]}
]
cantor[size_, 0][pt_] := Rectangle[pt, pt + {size, size}]
drawCantor[n_] := Graphics[cantor[1, n][{0, 0}]]
drawCantor[5]
Explanation: size is the edge length of the square the set fits into. pt is the {x,y} coordinates of it lower left corner.