Related
I have a 20000 x 185 x 5 tensor, which looks like
{{{a1_1,a2_1,a3_1,a4_1,a5_1},{b1_1,b2_1,b3_1,b4_1,b5_1}...
(continue for 185 times)}
{{a1_2,a2_2,a3_2,a4_2,a5_2},{b1_2,b2_2,b3_2,b4_2,b5_2}...
...
...
...
{{a1_20000,a2_20000,a3_20000,a4_20000,a5_20000},
{b1_20000,b2_20000,b3_20000,b4_20000,b5_20000}... }}
The 20000 represents iteration number, the 185 represents individuals, and each individual has 5 attributes. I need to construct a 185 x 5 matrix that stores the mean value for each individual's 5 attributes, averaged across the 20000 iterations.
Not sure what the best way to do this is. I know Mean[ ] works on matrices, but with a Tensor, the derived values might not be what I need. Also, Mathematica ran out of memory if I tried to do Mean[tensor]. Please provide some help or advice. Thank you.
When in doubt, drop the size of the dimensions. (You can still keep them distinct to easily see where things end up.)
(* In[1]:= *) data = Array[a, {4, 3, 2}]
(* Out[1]= *) {{{a[1, 1, 1], a[1, 1, 2]}, {a[1, 2, 1],
a[1, 2, 2]}, {a[1, 3, 1], a[1, 3, 2]}}, {{a[2, 1, 1],
a[2, 1, 2]}, {a[2, 2, 1], a[2, 2, 2]}, {a[2, 3, 1],
a[2, 3, 2]}}, {{a[3, 1, 1], a[3, 1, 2]}, {a[3, 2, 1],
a[3, 2, 2]}, {a[3, 3, 1], a[3, 3, 2]}}, {{a[4, 1, 1],
a[4, 1, 2]}, {a[4, 2, 1], a[4, 2, 2]}, {a[4, 3, 1], a[4, 3, 2]}}}
(* In[2]:= *) Dimensions[data]
(* Out[2]= *) {4, 3, 2}
(* In[3]:= *) means = Mean[data]
(* Out[3]= *) {
{1/4 (a[1, 1, 1] + a[2, 1, 1] + a[3, 1, 1] + a[4, 1, 1]),
1/4 (a[1, 1, 2] + a[2, 1, 2] + a[3, 1, 2] + a[4, 1, 2])},
{1/4 (a[1, 2, 1] + a[2, 2, 1] + a[3, 2, 1] + a[4, 2, 1]),
1/4 (a[1, 2, 2] + a[2, 2, 2] + a[3, 2, 2] + a[4, 2, 2])},
{1/4 (a[1, 3, 1] + a[2, 3, 1] + a[3, 3, 1] + a[4, 3, 1]),
1/4 (a[1, 3, 2] + a[2, 3, 2] + a[3, 3, 2] + a[4, 3, 2])}
}
(* In[4]:= *) Dimensions[means]
(* Out[4]= *) {3, 2}
Mathematica ran out of memory if I tried to do Mean[tensor]
This is probably because intermediate results are larger than the final result. This is likely if the elements are not type Real or Integer. Example:
a = Tuples[{x, Sqrt[y], z^x, q/2, Mod[r, 1], Sin[s]}, {2, 4}];
{MemoryInUse[], MaxMemoryUsed[]}
b = Mean[a];
{MemoryInUse[], MaxMemoryUsed[]}
{109125576, 124244808}
{269465456, 376960648}
If they are, and are in packed array form, perhaps the elements are such that the array in unpacked during processing.
Here is an example where the tensor is a packed array of small numbers, and unpacking does not occur.
a = RandomReal[99, {20000, 185, 5}];
PackedArrayQ[a]
{MemoryInUse[], MaxMemoryUsed[]}
b = Mean[a];
{MemoryInUse[], MaxMemoryUsed[]}
True
{163012808, 163016952}
{163018944, 163026688}
Here is the same size of tensor with very large numbers.
a = RandomReal[$MaxMachineNumber, {20000, 185, 5}];
Developer`PackedArrayQ[a]
{MemoryInUse[], MaxMemoryUsed[]}
b = Mean[a];
{MemoryInUse[], MaxMemoryUsed[]}
True
{163010680, 458982088}
{163122608, 786958080}
To elaborate a little on the other answers, there is no reason to expect Mathematica functions to operate materially differently on tensors than matrices because Mathemetica considers them both to be nested Lists, that are just of different nesting depth. How functions behave with lists depends on whether they're Listable, which you can check using Attributes[f], where fis the function you are interested in.
Your data list's dimensionality isn't actually that big in the scheme of things. Without seeing your actual data it is hard to be sure, but I suspect the reason you are running out of memory is that some of your data is non-numerical.
I don't know what you're doing incorrectly (your code will help). But Mean[] already works as you want it to.
a = RandomReal[1, {20000, 185, 5}];
b = Mean#a;
Dimensions#b
Out[1]= {185, 5}
You can even check that this is correct:
{Max#b, Min#b}
Out[2]={0.506445, 0.494061}
which is the expected value of the mean given that RandomReal uses a uniform distribution by default.
Assume you have the following data :
a = Table[RandomInteger[100], {i, 20000}, {j, 185}, {k, 5}];
In a straightforward manner You can find a table which stores the means of a[[1,j,k]],a[[2,j,k]],...a[[20000,j,k]]:
c = Table[Sum[a[[i, j, k]], {i, Length[a]}], {j, 185}, {k, 5}]/
Length[a] // N; // Timing
{37.487, Null}
or simply :
d = Total[a]/Length[a] // N; // Timing
{0.702, Null}
The second way is about 50 times faster.
c == d
True
To extend on Brett's answer a bit, when you call Mean on a n-dimensional tensor then it averages over the first index and returns an n-1 dimensional tensor:
a = RandomReal[1, {a1, a2, a3, ... an}];
Dimensions[a] (* This would have n entries in it *)
b = Mean[a];
Dimensions[b] (* Has n-1 entries, where averaging was done over the first index *)
In the more general case where you may wish to average over the i-th argument, you would have to transpose the data around first. For example, say you want to average the 3nd of 5 dimensions. You would need the 3rd element first, followed by the 1st, 2nd, 4th, 5th.
a = RandomReal[1, {5, 10, 2, 40, 10}];
b = Transpose[a, {2, 3, 4, 1, 5}];
c = Mean[b]; (* Now of dimensions {5, 10, 40, 10} *)
In other words, you would make a call to Transpose where you placed the i-th index as the first tensor index and moved everything before it ahead one. Anything that comes after the i-th index stays the same.
This tends to come in handy when your data comes in odd formats where the first index may not always represent different realizations of a data sample. I've had this come up, for example, when I had to do time averaging of large wind data sets where the time series came third (!) in terms of the tensor representation that was available.
You could imagine the generalizedTenorMean would look something like this then:
Clear[generalizedTensorMean];
generalizedTensorMean[A_, i_] :=
Module[{n = Length#Dimensions#A, ordering},
ordering =
Join[Table[x, {x, 2, i}], {1}, Table[x, {x, i + 1, n}]];
Mean#Transpose[A, ordering]]
This reduces to the plain-old-mean when i == 1. Try it out:
A = RandomReal[1, {2, 4, 6, 8, 10, 12, 14}];
Dimensions#A (* {2, 4, 6, 8, 10, 12, 14} *)
Dimensions#generalizedTensorMean[A, 1] (* {4, 6, 8, 10, 12, 14} *)
Dimensions#generalizedTensorMean[A, 7] (* {2, 4, 6, 8, 10, 12} *)
On a side note, I'm surprised that Mathematica doesn't support this by default. You don't always want to average over the first level of a list.
I tried to do the following :
Do[
f1 = StringReplace[
"obsxxxx.out", {"xxxx" -> ToString[i]}];
Print[f1];
,
{i, 200}];
and obtain
obs0001.out
obs0002.out
...
obs0010.out
...
obs0100.out
...
and so on.
I tried that:
ToString[Flatten[IntegerDigits[20, 10, 4]]]
but I still have a list ...
Perhaps you require something like:
Table[IntegerString[i, 10, 4], {i, 1, 10}]
giving
{"0001", "0002", "0003", "0004", "0005", "0006", "0007", "0008",
"0009", "0010"}
or
Table["obs" <> IntegerString[i, 10, 4] <> ".out", {i, 1, 10}]
giving
{"obs0001.out", "obs0002.out", "obs0003.out", "obs0004.out",
"obs0005.out", "obs0006.out", "obs0007.out", "obs0008.out",
"obs0009.out", "obs0010.out"}
I would like your help on something,
I have a Table:
InitialMatrix[x_, y_, age_, disease_] :=
ReplacePart[Table[Floor[Divide[dogpopulation/cellsno,9]], {x}, {y}, {age}, {disease}],
{{_, _, 1, _} -> 0, {_, _, 3, _} -> 6}];
I was trying to set up a condition to change all the values inside the table to sumthing else, according to a value, I tried:
listInitial={};
For[a = 1, a < 4, a++,
For[b = 1, b < 4, b++,
For[x = 1, x < 4, x = x + 1,
For[z = 1, z < 4, z = z + 1,
listInitial =
If[Random[] > psurvival,
ReplacePart[ InitialMatrix[3, 3, 3, 3], {a, b, x, z} ->
InitialMatrix[3, 3, 3, 3][[a]][[b]][[x]][[z]] - 1],
InitialMatrix[3, 3, 3, 3], {a, b, x, z} ->
InitialMatrix[3, 3, 3, 3][[a]][[b]][[x]][[z]]]]]]]
but it only changes the last part of my table, finally I decided to use the following code instead of the for loop,
SetAttributes[myFunction, Listable]
myFunction[x_] :=
If[Random[] > psurvival, If [x - 1 < 0 , x , x - 1], x]
myFunction[InitialMatrix[3, 3, 3, 3]] // TableForm
but now I want to change specific parts inside the table, for example I want all the part
{__,__,3,_} to change I tried to choose the range with MapAt but again I think I need to do a loop, and I cannot, can any one please help me?
For[x = 1, x < 4, x++,
listab[MapAt[f, InitialMatrix[3, 3, 3, 3], {x, 3, 3}]//TableForm]]
If you check out the documentation for MapAt, you will see that you can address multiple elements at various depths of your tensor, using various settings of the third argument. Note also the use of Flatten's second argument. I think this is what you are looking for.
MapAt[g, InitialMatrix[3, 3, 3, 3],
Flatten[Table[{i, j, 3, k}, {i, 3}, {j, 3}, {k, 3}], 2]]
http://reference.wolfram.com/mathematica/ref/MapAt.html
http://reference.wolfram.com/mathematica/ref/Flatten.html
Since this seems to be your second attempt to ask a question involving a really complicated For loop, may I just emphasise that you almost never need a For or Do loop in Mathematica in the circumstances where you would use one in, say, Fortran or C. Certainly not for most construction of lists. Table works. So do things like Listable functions (which I know you know) and commands like NestList, FoldList and Array.
You will probably also find this tutorial useful.
http://reference.wolfram.com/mathematica/tutorial/SelectingPartsOfExpressionsWithFunctions.html
I used the following code as an answer, I am not sure whether is the best solution or not, but it works!!
InitialTable[x_, y_, z_, w_] :=
MapAt[g,ReplacePart[
InitialMatrix[3, 3, 3, 3] +
ReplacePart[
Table[If[RandomReal[] > psurvival, -1,
0], {3}, {3}, {3}, {3}], {{_, _, 1, _} -> 0, {_, _, 2, _} ->
0}], {{_, _, 1, 2} -> 0, {_, _, 1, 3} -> 0}],
Flatten[Table[{i, j, 3, l}, {i, x}, {j, y}, {l, w}], 2]];
g[x_] := If[x < 0, 0, x];
Suppose we want to generate a list of primes p for which p + 2 is also prime.
A quick solution is to generate a complete list of the first n primes and use the Select function to return the elements which meet the condition.
Select[Table[Prime[k], {k, n}], PrimeQ[# + 2] &]
However, this is inefficient as it loads a large list into the memory before returning the filtered list. A For loop with Sow/Reap (or l = {}; AppendTo[l, k]) solves the memory issue, but it is far from elegant and is cumbersome to implement a number of times in a Mathematica script.
Reap[
For[k = 1, k <= n, k++,
p = Prime[k];
If[PrimeQ[p + 2], Sow[p]]
]
][[-1, 1]]
An ideal solution would be a built-in function which allows an option similar to this.
Table[Prime[k], {k, n}, AddIf -> PrimeQ[# + 2] &]
I will interpret this more as a question about automation and software engineering rather than about the specific problem at hand, and given a large number of solutions posted already. Reap and Sow are good means (possibly, the best in the symbolic setting) to collect intermediate results. Let us just make it general, to avoid code duplication.
What we need is to write a higher-order function. I will not do anything radically new, but will simply package your solution to make it more generally applicable:
Clear[tableGen];
tableGen[f_, iter : {i_Symbol, __}, addif : Except[_List] : (True &)] :=
Module[{sowTag},
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[#,sowTag]] &[f[i]], iter],sowTag]];
The advantages of using Do over For are that the loop variable is localized dynamically (so, no global modifications for it outside the scope of Do), and also the iterator syntax of Do is closer to that of Table (Do is also slightly faster).
Now, here is the usage
In[56]:= tableGen[Prime, {i, 10}, PrimeQ[# + 2] &]
Out[56]= {3, 5, 11, 17, 29}
In[57]:= tableGen[Prime, {i, 3, 10}, PrimeQ[# + 1] &]
Out[57]= {}
In[58]:= tableGen[Prime, {i, 10}]
Out[58]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}
EDIT
This version is closer to the syntax you mentioned (it takes an expression rather than a function):
ClearAll[tableGenAlt];
SetAttributes[tableGenAlt, HoldAll];
tableGenAlt[expr_, iter_List, addif : Except[_List] : (True &)] :=
Module[{sowTag},
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[#,sowTag]] &[expr], iter],sowTag]];
It has an added advantage that you may even have iterator symbols defined globally, since they are passed unevaluated and dynamically localized. Examples of use:
In[65]:= tableGenAlt[Prime[i], {i, 10}, PrimeQ[# + 2] &]
Out[65]= {3, 5, 11, 17, 29}
In[68]:= tableGenAlt[Prime[i], {i, 10}]
Out[68]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}
Note that since the syntax is different now, we had to use the Hold-attribute to prevent the passed expression expr from premature evaluation.
EDIT 2
Per #Simon's request, here is the generalization for many dimensions:
ClearAll[tableGenAltMD];
SetAttributes[tableGenAltMD, HoldAll];
tableGenAltMD[expr_, iter__List, addif : Except[_List] : (True &)] :=
Module[{indices, indexedRes, sowTag},
SetDelayed ## Prepend[Thread[Map[Take[#, 1] &, List ## Hold ### Hold[iter]],
Hold], indices];
indexedRes =
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[{#, indices},sowTag]] &[expr], iter],sowTag];
Map[
First,
SplitBy[indexedRes ,
Table[With[{i = i}, Function[Slot[1][[2, i]]]], {i,Length[Hold[iter]] - 1}]],
{-3}]];
It is considerably less trivial, since I had to Sow the indices together with the added values, and then split the resulting flat list according to the indices. Here is an example of use:
{i, j, k} = {1, 2, 3};
tableGenAltMD[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}, # < 7 &]
{{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}
I assigned the values to i,j,k iterator variables to illustrate that this function does localize the iterator variables and is insensitive to possible global values for them. To check the result, we may use Table and then delete the elements not satisfying the condition:
In[126]:=
DeleteCases[Table[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}],
x_Integer /; x >= 7, Infinity] //. {} :> Sequence[]
Out[126]= {{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}
Note that I did not do extensive checks so the current version may contain bugs and needs some more testing.
EDIT 3 - BUG FIX
Note the important bug-fix: in all functions, I now use Sow with a custom unique tag, and Reap as well. Without this change, the functions would not work properly when expression they evaluate also uses Sow. This is a general situation with Reap-Sow, and resembles that for exceptions (Throw-Catch).
EDIT 4 - SyntaxInformation
Since this is such a potentially useful function, it is nice to make it behave more like a built-in function. First we add syntax highlighting and basic argument checking through
SyntaxInformation[tableGenAltMD] = {"ArgumentsPattern" -> {_, {_, _, _., _.}.., _.},
"LocalVariables" -> {"Table", {2, -2}}};
Then, adding a usage message allows the menu item "Make Template" (Shift+Ctrl+k) to work:
tableGenAltMD::usage = "tableGenAltMD[expr,{i,imax},addif] will generate \
a list of values expr when i runs from 1 to imax, \
only including elements if addif[expr] returns true.
The default of addiff is True&."
A more complete and formatted usage message can be found in this gist.
I think the Reap/Sow approach is likely to be most efficient in terms of memory usage. Some alternatives might be:
DeleteCases[(With[{p=Prime[#]},If[PrimeQ[p+2],p,{}] ] ) & /# Range[K]),_List]
Or (this one might need some sort of DeleteCases to eliminate Null results):
FoldList[[(With[{p=Prime[#2]},If[PrimeQ[p+2],p] ] )& ,1.,Range[2,K] ]
Both hold a big list of integers 1 to K in memory, but the Primes are scoped inside the With[] construct.
Yes, this is another answer. Another alternative that includes the flavour of the Reap/Sow approach and the FoldList approach would be to use Scan.
result = {1};
Scan[With[{p=Prime[#]},If[PrimeQ[p+2],result={result,p}]]&,Range[2,K] ];
Flatten[result]
Again, this involves a long list of integers, but the intermediate Prime results are not stored because they are in the local scope of With. Because p is a constant in the scope of the With function, you can use With rather than Module, and gain a bit of speed.
You can perhaps try something like this:
Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] := Union#Flatten#(f /# Range[k]);
If you want both the prime p and the prime p+2, then the solution is
Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] :=
Module[{primes = f /# Range[k]},
Union#Flatten#{primes, primes + 2}];
Well, someone has to allocate memory somewhere for the full table size, since it is not known before hand what the final size will be.
In the good old days before functional programming :), this sort of thing was solved by allocating the maximum array size, and then using a separate index to insert to it so no holes are made. Like this
x=Table[0,{100}]; (*allocate maximum possible*)
j=0;
Table[ If[PrimeQ[k+2], x[[++j]]=k],{k,100}];
x[[1;;j]] (*the result is here *)
{1,3,5,9,11,15,17,21,27,29,35,39,41,45,51,57,59,65,69,71,77,81,87,95,99}
Here's another couple of alternatives using NextPrime:
pairs1[pmax_] := Select[Range[pmax], PrimeQ[#] && NextPrime[#] == 2 + # &]
pairs2[pnum_] := Module[{p}, NestList[(p = NextPrime[#];
While[p + 2 != (p = NextPrime[p])];
p - 2) &, 3, pnum]]
and a modification of your Reap/Sow solution that lets you specify the maximum prime:
pairs3[pmax_] := Module[{k,p},
Reap[For[k = 1, (p = Prime[k]) <= pmax, k++,
If[PrimeQ[p + 2], Sow[p]]]][[-1, 1]]]
The above are in order of increasing speed.
In[4]:= pairs2[10000]//Last//Timing
Out[4]= {3.48,1261079}
In[5]:= pairs1[1261079]//Last//Timing
Out[5]= {6.84,1261079}
In[6]:= pairs3[1261079]//Last//Timing
Out[7]= {0.58,1261079}
The Table[ ] command usually returns a list with the same cardinality of its iterator.
Table[i, {i,4}]
(*
->{1,2,3,4}
*)
It is easy to show that is possible to return a list with a greater cardinality than the iterator
Table[Sequence ## ConstantArray[1, i], {i, 2}]
(*
->{1,1,1}
*)
But ... Are there ways to return a list with LESS cardinality than the iterator?
This should work:
Table[Sequence ## {}, {i, 10}]
Assuming that I now understand your intent, I do not see the advantage to "on the fly" elimination within Table itself. One could accomplish it with something like:
Table[If[EvenQ#i, i, ##&[]], {i, 25}]
but it is faster to use Join:
Join ## Table[If[EvenQ#i, {i}, {}], {i, 25}]
or DeleteCases:
DeleteCases[Table[If[EvenQ#i, i], {i, 25}], , 1]
and in this simple case, Select is more than twice as fast:
Table[i, {i, 25}] ~Select~ EvenQ
If it is a matter of memory usage, the first method using Sequence does come out ahead, but the Join method is not far behind.
A simple example:
Table[Sequence ## ConstantArray[1, i - 1], {i, 2}]
Out[1] = {1}
This need not always return a list with smaller cardinality. For e.g., {i,3} returns equal and {i,4} returns more.
Or an even sillier example would be
Table[Sequence ## {}, {i, 2}]
but I don't know if it counts.
You could also use Piecewise inside Table
Table[Sequence ## Piecewise[{
{ConstantArray[1, i], i < 3},
{ConstantArray[2, i], 3 <= i < 5},
{{}, i >= 5}}],
{i, 20}]
Out[2] = {1, 1, 1, 2, 2, 2, 2, 2, 2, 2}