I would like to compile a custom function that I created in order to speed up the computation time, which is already small but I am calling the function quite a "few times".
Some dummy data:
DD = 20; Days = 4; Peak = 1;
Loading =
Table[Table[{RandomReal[{-1500, 1500}],
RandomReal[{-1, 1}/100]}, {i, 1, 150}], {j, 1, Days}];
coo = Loading[[All, All, 1]];
The function:
Clear[TimeSwapFunctionTEST];
TimeSwapFunctionTEST[lst_ /; (And ## (NumericQ /# lst))] :=
Norm[With[{z =
Sort[Partition[
Flatten[Riffle[Flatten[coo + lst],
Flatten[Loading[[1 ;; Days, All, Peak + 1]]]]],
2], #1[[1]] < #2[[1]] &]},
Mean[Select[
Partition[
Riffle[Mean[Transpose[Partition[z[[All, 1]], DD]]],
Abs[Mean[
Transpose[
Partition[z[[All, 2]], DD]]]/(StandardDeviation[
Transpose[Partition[z[[All, 2]], DD]]]/Sqrt[DD])]],
2], #1[[1]] > 0 &][[All, 2]]]]]
The computation time is around 6" for a thousand shots:
AbsoluteTiming[Do[TimeSwapFunctionTEST[{0, 0, 0, 0}], {i, 1, 1000}]]
{6.0323450, Null}
I tried already but I have some problem with the argument lst_ /; (And ## (NumericQ /# lst)) so I have to remove it (but I will need it at the end).
So if I tried this:
Clear[TimeSwapFunctionTESTCompiled];
TimeSwapFunctionTESTCompiled =
Compile[{{lst(*/;(And##(NumericQ/#lst))*), _Real}},
With[{x =
Sort[Partition[
Flatten[Riffle[Flatten[coo + lst],
Flatten[Loading[[1 ;; Days, 1 ;; -1, Peak + 1]]]]],
2], #1[[1]] < #2[[1]] &]},
Mean[Select[
Partition[
Riffle[Mean[Transpose[Partition[x[[All, 1]], DD]]],
Abs[Mean[
Transpose[
Partition[x[[All, 2]], DD]]]/(StandardDeviation[
Transpose[Partition[x[[All, 2]], DD]]]/Sqrt[DD])]],
2], #1[[1]] > 0 &][[All, 2]]]]]
I got these errors:
Compile::part: Part specification Compile`FunctionVariable$25889[[All,2]] cannot be compiled since the argument is not a tensor of sufficient rank. Evaluation will use the uncompiled function. >>
Compile::cplist: Compile`$5 should be a tensor of type Integer, Real, or Complex; evaluation will use the uncompiled function. >>
Compile::cplist: Compile`$5 should be a tensor of type Integer, Real, or Complex; evaluation will use the uncompiled function. >>
Compile::cplist: Compile`$6 should be a tensor of type Integer, Real, or Complex; evaluation will use the uncompiled function. >>
General::stop: Further output of Compile::cplist will be suppressed during this calculation. >>
Compile::part: Part specification Compile`FunctionVariable$25889[[All,1]] cannot be compiled since the argument is not a tensor of sufficient rank. Evaluation will use the uncompiled function. >>
Compile::part: Part specification Compile`FunctionVariable$25889[[All,1]] cannot be compiled since the argument is not a tensor of sufficient rank. Evaluation will use the uncompiled function. >>
General::stop: Further output of Compile::part will be suppressed during this calculation. >>
do you have any idea in order to compile this?
Thanks
Related
My aim is to create a lot of functions f_i in a loop. These functions depend on parameters a[[i]], which can be taken from array A = {a1, a2, ...}. In order to eliminate the influence of the interator i, which leads to the situation when all functions are the same, I aspire to create variable names for each iteration.
The example: suppose I have got the array W = {1,2,3, ..., 100} and I should create variables w1 = 1, w2 = 2, ..., w100 = 100. I am trying to do this with the help of a for-loop:
loc[expr1_, expr2_] :=
ToExpression[StringJoin[ToString[expr1], ToString[expr2]]];
For[i = 1, i <= 100, i++,
{
loc[w, i] = W[[i]];
}]
When I need to see which value variable wk contains, then wk is not defined. But loc[w, k] = k is known.
How can I define variables wi? Or is there another way to create functions in a loop?
Thanks in advance
The way you are using {} leads me to believe that you have prior experience with other programming languages.
Mathematica is a very different language and some of what you know and expect will be wrong. Mathematica only uses {} to mean that is a list of elements. It is not used to group blocks of code. ; is more often used to group blocks of code.
Next, try
W={1,2,3};
For[i=i,i<=3,i++,
ToExpression["w"<>ToString[i]<>"="<>ToString[i]]
];
w2
and see that that returns
2
I understand that there is an intense desire in people who have been trained in other programming languages to use For to accomplish things. There are other ways o doing that for most purposes in Mathematica.
For one simple example
W={1,2,3};
Map[ToExpression["z"<>ToString[#]<>"="<>ToString[#]]&,W];
z2
returns
2
where I used z instead of w just to be certain that it wasn't showing me a prior cached value of w2
You can even do things like
W={1,2,3};
loc[n_,v_]:=ToExpression[ToString[n]<>ToString[v]<>"="<>ToString[v]];
Map[loc[a,#]&,W];
a3
which returns
3
Ordinarily, you will use indexed variables for this. E.g.,
ClearAll[x, xs]
n = 4
xs = Array[Indexed[x, #] &, 4]
Example use with random data:
RandomSeed[314]
mA = RandomInteger[{0, 99}, {n, n}]
vb = RandomInteger[{0, 99}, n]
Solve[mA.xs == vb, xs]
This is just for illustration; one would ordinarily use LinearSolve for the example problem. E.g., MapThread[Rule, {xs, LinearSolve[mA, vb]}].
It would be simpler to use a function variable, e.g. w[1], but here is a method to define w1 etc.
Note Clear can clear assignments using string versions of the symbols.
W = {1, 2, 7, 9};
Clear ## Map["w" <> ToString[#] &, W]
Map[(Evaluate[Symbol["w" <> ToString[#]]] = #) &, W];
w9
9
Symbol /# Map["w" <> ToString[#] &, W]
{1, 2, 7, 9}
Alternatively, with a function variable . . .
Map[(w[#] = #) &, W]
{1, 2, 7, 9}
w[9]
9
Also, using the OP's structure
Clear[loc]
Clear[w]
Clear ## Map["w" <> ToString[#] &, W]
W = {1, 2, 3, 4};
loc[expr1_, expr2_] := StringJoin[ToString[expr1], ToString[expr2]]
For[i = 1, i <= 4, i++, Evaluate[Symbol[loc[w, i]]] = W[[i]]]
Symbol /# Map["w" <> ToString[#] &, W]
{1, 2, 3, 4}
Note Evaluate[Symbol[loc[w, i]]] = W[[i]]] has the advantage that if the data at W[[i]] is a string it does not get transformed as it would by using ToExpression.
I am trying to define an object which function in some variable and tensor in other indices.
My attempt at it was:
Clear[mat, k];
mat[k_] := {{0,0},{0,0}};
mat[k_][[1, 1]] := k + 1
mat[k_][[1, 2]] := k + 2
mat[k_][[2, 1]] := k + 3
mat[k_][[2, 2]] := k + 4
mat[1]
The ouput it gives is:
During evaluation of In[268]:= SetDelayed::setps: mat[k_] in the part assignment is not a symbol. >>
Out[270]= $Failed
During evaluation of In[268]:= SetDelayed::setps: mat[k_] in the part assignment is not a symbol. >>
Out[271]= $Failed
During evaluation of In[268]:= SetDelayed::setps: mat[k_] in the part assignment is not a symbol. >>
Out[272]= $Failed
During evaluation of In[268]:= SetDelayed::setps: mat[k_] in the part assignment is not a symbol. >>
Out[273]= $Failed
Out[274]= {{0, 0}, {0, 0}}
Could someone please points me out as to what's going wrong here and what are the ways to get what i want?
mat[k_] is a pattern not a symbol. mat[k_] := {{0,0},{0,0}} defines a single variable function that returns the 2x2 array. mat[k_] has Head mat and Part 1 k_.
I believe you want to define mat has follows in its own cell.
mat[k_] := {{k + 1, k + 2}, {k + 3, k + 4}}
Then in another cell
mat[1]
(* {{2, 3}, {4, 5}} *)
Hope this helps.
To illustrate my problem here is a toy example:
F[x_] := Module[{out},
If[x > 1,
out = 1/2,
out = 1
];
out
];
The function can be evaluated and plotted. However when I try to numerically integrate it I get an error
NIntegrate[F[x], {x, 0, 2}]
NIntegrate::inumr: The integrand out$831 has evaluated to non-numerical values for all sampling points in the region with boundaries {{0,2}}. >>
Integrate and some other functions will do some probing with symbolic values first. Your Module when given only the symbol x will return only the (aliased) out.
Fix this by defining your F only for numeric values. NIntegrate will discover this and then use numeric values.
In[1]:= F[x_?NumericQ] := Module[{out},
If[x > 1, out = 1/2, out = 1]; out];
NIntegrate[F[x], {x, 0, 2}]
Out[2]= 1.5
This is a fun little problem, and I wanted to check with the experts here if there is a better functional/Mathematica way to approach solving it than what I did. I am not too happy with my solution since I use big IF THEN ELSE in it, but could not find a Mathematica command to use easily to do it (such as Select, Cases, Sow/Reap, Map.. etc...)
Here is the problem, given a list values (numbers or symbols), but for simplicity, lets assume a list of numbers for now. The list can contain zeros and the goal is replace the each zero with the element seen before it.
At the end, the list should contain no zeros in it.
Here is an example, given
a = {1, 0, 0, -1, 0, 0, 5, 0};
the result should be
a = {1, 1, 1, -1, -1, -1, 5, 5}
It should ofcourse be done in the most efficient way.
This is what I could come up with
Scan[(a[[#]] = If[a[[#]] == 0, a[[#-1]], a[[#]]]) &, Range[2, Length[a]]];
I wanted to see if I can use Sow/Reap on this, but did not know how.
question: can this be solved in a more functional/Mathematica way? The shorter the better ofcourse :)
update 1
Thanks everyone for the answer, all are very good to learn from. This is the result of speed test, on V 8.04, using windows 7, 4 GB Ram, intel 930 #2.8 Ghz:
I've tested the methods given for n from 100,000 to 4 million. The ReplaceRepeated method does not do well for large lists.
update 2
Removed earlier result that was shown above in update1 due to my error in copying one of the tests.
The updated results are below. Leonid method is the fastest. Congratulation Leonid. A very fast method.
The test program is the following:
(*version 2.0 *)
runTests[sizeOfList_?(IntegerQ[#] && Positive[#] &)] :=
Module[{tests, lst, result, nasser, daniel, heike, leonid, andrei,
sjoerd, i, names},
nasser[lst_List] := Module[{a = lst},
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]]
];
daniel[lst_List] := Module[{replaceWithPrior},
replaceWithPrior[ll_, n_: 0] :=
Module[{prev}, Map[If[# == 0, prev, prev = #] &, ll]
];
replaceWithPrior[lst]
];
heike[lst_List] := Flatten[Accumulate /# Split[lst, (#2 == 0) &]];
andrei[lst_List] := Module[{x, y, z},
ReplaceRepeated[lst, {x___, y_, 0, z___} :> {x, y, y, z},
MaxIterations -> Infinity]
];
leonid[lst_List] :=
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] & #lst;
sjoerd[lst_List] :=
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, lst];
lst = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]],
sizeOfList];
tests = {nasser, daniel, heike, leonid, sjoerd};
names = {"Nasser","Daniel", "Heike", "Leonid", "Sjoerd"};
result = Table[0, {Length[tests]}, {2}];
Do[
result[[i, 1]] = names[[i]];
Block[{j, r = Table[0, {5}]},
Do[
r[[j]] = First#Timing[tests[[i]][lst]], {j, 1, 5}
];
result[[i, 2]] = Mean[r]
],
{i, 1, Length[tests]}
];
result
]
To run the tests for length 1000 the command is:
Grid[runTests[1000], Frame -> All]
Thanks everyone for the answers.
Much (order of magnitude) faster than other solutions still:
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] &
The speedup is due to Fold autocompiling. Will not be so dramatic for non-packed arrays. Benchmarks:
In[594]:=
a=b=c=RandomChoice[Join[ConstantArray[0,10],Range[-1,5]],150000];
(b=Flatten[Accumulate/#Split[b,(#2==0)&]]);//Timing
Scan[(a[[#]]=If[a[[#]]==0,a[[#-1]],a[[#]]])&,Range[2,Length[a]]]//Timing
(c=FoldList[If[#2==0,#1,#2]&,First##,Rest##]&#c);//Timing
SameQ[a,b,c]
Out[595]= {0.187,Null}
Out[596]= {0.625,Null}
Out[597]= {0.016,Null}
Out[598]= True
This seems to be a factor 4 faster on my machine:
a = Flatten[Accumulate /# Split[a, (#2 == 0) &]]
The timings I get are
a = b = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]], 10000];
(b = Flatten[Accumulate /# Split[b, (#2 == 0) &]]); // Timing
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]] // Timing
SameQ[a, b]
(* {0.015815, Null} *)
(* {0.061929, Null} *)
(* True *)
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, d]
is about 10 and 2 times faster than Heike's solutions but slower than Leonid's.
You question looks exactly like a task for ReplaceRepeated function. What it does basically is that it applies the same set of rules to the expression until no more rules are applicable. In your case the expression is a list, and the rule is to replace 0 with its predecessor whenever occurs in a list. So here is the solution:
a = {1, 0, 0, -1, 0, 0, 5, 0};
a //. {x___, y_, 0, z___} -> {x, y, y, z};
The pattern for the rule here is the following:
x___ - any symbol, zero or more repetitions, the beginning of the list
y_ - exactly one element before zero
0 - zero itself, this element will be replaced with y later
z___ - any symbol, zero or more repetitions, the end of the list
In Mathematica there are a number of functions that return not only the final result or a single match, but all results. Such functions are named *List. Exhibit:
FoldList
NestList
ReplaceList
ComposeList
Something that I am missing is a MapList function.
For example, I want:
MapList[f, {1, 2, 3, 4}]
{{f[1], 2, 3, 4}, {1, f[2], 3, 4}, {1, 2, f[3], 4}, {1, 2, 3, f[4]}}
I want a list element for each application of the function:
MapList[
f,
{h[1, 2], {4, Sin[x]}},
{2}
] // Column
{h[f[1], 2], {4, Sin[x]}}
{h[1, f[2]], {4, Sin[x]}}
{h[1, 2], {f[4], Sin[x]}}
{h[1, 2], {4, f[Sin[x]]}}
One may implement this as:
MapList[f_, expr_, level_: 1] :=
MapAt[f, expr, #] & /#
Position[expr, _, level, Heads -> False]
However, it is quite inefficient. Consider this simple case, and compare these timings:
a = Range#1000;
#^2 & /# a // timeAvg
MapList[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
0.00005088
0.01436
0.0003744
This illustrates that on average MapList is about 38X slower than the combined total of mapping the function to every element in the list and creating a 1000x1000 array.
Therefore, how may MapList be most efficiently implemented?
I suspect that MapList is nearing the performance limit for any transformation that performs structural modification. The existing target benchmarks are not really fair comparisons. The Map example is creating a simple vector of integers. The ConstantArray example is creating a simple vector of shared references to the same list. MapList shows poorly against these examples because it is creating a vector where each element is a freshly generated, unshared, data structure.
I have added two more benchmarks below. In both cases each element of the result is a packed array. The Array case generates new elements by performing Listable addition on a. The Module case generates new elements by replacing a single value in a copy of a. These results are as follows:
In[8]:= a = Range#1000;
#^2 & /# a // timeAvg
MapList[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
Array[a+# &, 1000] // timeAvg
Module[{c}, Table[c = a; c[[i]] = c[[i]]^2; c, {i, 1000}]] // timeAvg
Out[9]= 0.0005504
Out[10]= 0.0966
Out[11]= 0.003624
Out[12]= 0.0156
Out[13]= 0.02308
Note how the new benchmarks perform much more like MapList and less like the Map or ConstantArray examples. This seems to show that there is not much scope for dramatically improving the performance of MapList without some deep kernel magic. We can shave a bit of time from MapList thus:
MapListWR4[f_, expr_, level_: {1}] :=
Module[{positions, replacements}
, positions = Position[expr, _, level, Heads -> False]
; replacements = # -> f[Extract[expr, #]] & /# positions
; ReplacePart[expr, #] & /# replacements
]
Which yields these timings:
In[15]:= a = Range#1000;
#^2 & /# a // timeAvg
MapListWR4[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
Array[a+# &, 1000] // timeAvg
Module[{c}, Table[c = a; c[[i]] = c[[i]]^2; c, {i, 1000}]] // timeAvg
Out[16]= 0.0005488
Out[17]= 0.04056
Out[18]= 0.003
Out[19]= 0.015
Out[20]= 0.02372
This comes within factor 2 of the Module case and I expect that further micro-optimizations can close the gap yet more. But it is with eager anticipation that I join you awaiting an answer that shows a further tenfold improvement.
(Updated my function)
I think I can offer another 2x boost on top of WReach's attempt.
Remove[MapListTelefunken];
MapListTelefunken[f_, dims_] :=
With[{a = Range[dims], fun = f[[1]]},
With[{replace = ({#, #} -> fun) & /# a},
ReplacePart[ConstantArray[a, {dims}], replace]
]
]
Here are the timings on my machine (Sony Z laptop; i7, 8GB ram, 256 SSD in Raid 0):
a = Range#1000;
#^2 & /# a; // timeAvg
MapList[#^2 &, a]; // timeAvg
MapListWR4[#^2 &, a]; // timeAvg
MapListTelefunken[#^2 &, 1000]; // timeAvg
0.0000296 (* just Mapping the function over a Range[1000] for baseline *)
0.0297 (* the original MapList proposed by Mr.Wizard *)
0.00936 (* MapListWR4 from WReach *)
0.00468 (* my attempt *)
I think you'd still need to create the 1000x1000 array, and I don't think there's any cleverer way than a constant array. More to the point, your examples are better served with the following definition, although I admit that it lacks the finesse of levels.
MapList[f_, list_] := (Table[MapAt[f, #, i], {i, Length##}] &)#list;
The culprit in your own definition is the Position[] call, which creates a complex auxiliary structure.
Provide a more complex use case, that will better cover your intentions.