Related
Suppose I want to construct a matrix A such that A[[i,i]]=f[x_,y_]+d[i], A[[i,i+1]]=u[i], A[[i+1,i]]=l[i], i=1,N . Say, f[x_,y_]=x^2+y^2.
How can I code this in Mathematica?
Additionally, if I want to integrate the first diagonal element of A, i.e. A[[1,1]] over x and y, both running from 0 to 1, how can I do that?
In[1]:= n = 4;
f[x_, y_] := x^2 + y^2;
A = Normal[SparseArray[{
{i_,i_}/;i>1 -> f[x,y]+ d[i],
{i_,j_}/;j-i==1 -> u[i],
{i_,j_}/;i-j==1 -> l[i-1],
{1, 1} -> Integrate[f[x,y]+d[1], {x,0,1}, {y,0,1}]},
{n, n}]]
Out[3]= {{2/3+d[1], l[1], 0, 0},
{u[1], x^2+y^2+ d[2], l[2], 0},
{0, u[2], x^2+y^2+d[3], l[3]},
{0, 0, u[3], x^2+y^2+d[4]}}
Band is tailored specifically for this:
myTridiagonalMatrix#n_Integer?Positive :=
SparseArray[
{ Band#{1, 1} -> f[x, y] + Array[d, n]
, Band#{1, 2} -> Array[u, n - 1]
, Band#{2, 1} -> Array[l, n - 1]}
, {n, n}]
Check it out (no need to define f, d, u, l):
myTridiagonalMatrix#5 // MatrixForm
Note that MatrixForm should not be part of a definition. For example, it's a bad idea to set A = (something) // MatrixForm. You will get a MatrixForm object instead of a table (= array of arrays) or a sparse array, and its only purpose is to be pretty-printed in FrontEnd. Trying to use MatrixForm in calculations will yield errors and will lead to unnecessary confusion.
Integrating the element at {1, 1}:
myTridiagonalMatrixWithFirstDiagonalElementIntegrated#n_Integer?Positive :=
MapAt[
Integrate[#, {x, 0, 1}, {y, 0, 1}]&
, myTridiagonalMatrix#n
, {1, 1}]
You may check it out without defining f or d, as well:
myTridiagonalMatrixWithFirstDiagonalElementIntegrated#5
The latter operation, however, looks suspicious. For example, it does not leave your matrix (or its corresponding linear system) invariant w.r.t. reasonable transformations. (This operation does not even preserve linearity of matrices.) You probably don't want to do it.
Comment on comment above: there's no need to define A[x_, y_] := … to Integrate[A[[1,1]], {x,0,1}, {y,0,1}]. Note that A[[1,1]] is totally different from A[1, 1]: the former is Part[A, 1, 1] which is a certain element of table A. A[1, 1] is a different expression: if A is some table then A[1, 1] is (that table)[1, 1], which is a valid expression but is normally considered meaningless.
Suppose I have two very large lists {a1, a2, …} and {b1, b2, …} where all ai and bj are large sparse arrays. For the sake of memory efficiency I store each list as one comprehensive sparse array.
Now I would like to compute some function f on all possible pairs of ai and bj where each result f[ai, bj] is a sparse array again. All these sparse arrays have the same dimensions, by the way.
While
Flatten[Outer[f, {a1, a2, ...}, {b1, b2, ...}, 1], 1]
returns the desired result (in principle) it appears to consume excessive amounts of memory. Not the least because the return value is a list of sparse arrays whereas one comprehensive sparse array turns out much more efficient in my cases of interest.
Is there an efficient alternative to the above use of Outer?
More specific example:
{SparseArray[{{1, 1, 1, 1} -> 1, {2, 2, 2, 2} -> 1}],
SparseArray[{{1, 1, 1, 2} -> 1, {2, 2, 2, 1} -> 1}],
SparseArray[{{1, 1, 2, 1} -> 1, {2, 2, 1, 2} -> 1}],
SparseArray[{{1, 1, 2, 2} -> -1, {2, 2, 1, 1} -> 1}],
SparseArray[{{1, 2, 1, 1} -> 1, {2, 1, 2, 2} -> 1}],
SparseArray[{{1, 2, 1, 2} -> 1, {2, 1, 2, 1} -> 1}],
SparseArray[{{1, 2, 2, 1} -> -1, {2, 1, 1, 2} -> 1}],
SparseArray[{{1, 2, 2, 2} -> 1, {2, 1, 1, 1} -> 1}]};
ByteCount[%]
list = SparseArray[%%]
ByteCount[%]
Flatten[Outer[Dot, list, list, 1], 1];
ByteCount[%]
list1x2 = SparseArray[%%]
ByteCount[%]
Flatten[Outer[Dot, list1x2, list, 1], 1];
ByteCount[%]
list1x3 = SparseArray[%%]
ByteCount[%]
etc. Not only are the raw intermediate results of Outer (lists of sparse arrays) extremely inefficient, Outer seems to consume way too much memory during the computation itself, too.
I will propose a solution which is rather complex but allows one to only use about twice as much memory during the computation as is needed to store the final result as a SparseArray. The price to pay for this will be a much slower execution.
The code
Sparse array construction / deconstruction API
Here is the code. First, a slightly modified (to address higher-dimensional sparse arrays) sparse array construction - deconstruction API, taken from this answer:
ClearAll[spart, getIC, getJR, getSparseData, getDefaultElement,
makeSparseArray];
HoldPattern[spart[SparseArray[s___], p_]] := {s}[[p]];
getIC[s_SparseArray] := spart[s, 4][[2, 1]];
getJR[s_SparseArray] := spart[s, 4][[2, 2]];
getSparseData[s_SparseArray] := spart[s, 4][[3]];
getDefaultElement[s_SparseArray] := spart[s, 3];
makeSparseArray[dims_List, jc_List, ir_List, data_List, defElem_: 0] :=
SparseArray ## {Automatic, dims, defElem, {1, {jc, ir}, data}};
Iterators
The following functions produce iterators. Iterators are a good way to encapsulate the iteration process.
ClearAll[makeTwoListIterator];
makeTwoListIterator[fname_Symbol, a_List, b_List] :=
With[{indices = Flatten[Outer[List, a, b, 1], 1]},
With[{len = Length[indices]},
Module[{i = 0},
ClearAll[fname];
fname[] := With[{ind = ++i}, indices[[ind]] /; ind <= len];
fname[] := Null;
fname[n_] :=
With[{ind = i + 1}, i += n;
indices[[ind ;; Min[len, ind + n - 1]]] /; ind <= len];
fname[n_] := Null;
]]];
Note that I could have implemented the above function more memory - efficiently and not use Outer in it, but for our purposes this won't be the major concern.
Here is a more specialized version, which produces interators for pairs of 2-dimensional indices.
ClearAll[make2DIndexInterator];
make2DIndexInterator[fname_Symbol, i : {iStart_, iEnd_}, j : {jStart_, jEnd_}] :=
makeTwoListIterator[fname, Range ## i, Range ## j];
make2DIndexInterator[fname_Symbol, ilen_Integer, jlen_Integer] :=
make2DIndexInterator[fname, {1, ilen}, {1, jlen}];
Here is how this works:
In[14]:=
makeTwoListIterator[next,{a,b,c},{d,e}];
next[]
next[]
next[]
Out[15]= {a,d}
Out[16]= {a,e}
Out[17]= {b,d}
We can also use this to get batch results:
In[18]:=
makeTwoListIterator[next,{a,b,c},{d,e}];
next[2]
next[2]
Out[19]= {{a,d},{a,e}}
Out[20]= {{b,d},{b,e}}
, and we will be using this second form.
SparseArray - building function
This function will build a SparseArray object iteratively, by getting chunks of data (also in SparseArray form) and gluing them together. It is basically code used in this answer, packaged into a function. It accepts the code piece used to produce the next chunk of data, wrapped in Hold (I could alternatively make it HoldAll)
Clear[accumulateSparseArray];
accumulateSparseArray[Hold[getDataChunkCode_]] :=
Module[{start, ic, jr, sparseData, dims, dataChunk},
start = getDataChunkCode;
ic = getIC[start];
jr = getJR[start];
sparseData = getSparseData[start];
dims = Dimensions[start];
While[True, dataChunk = getDataChunkCode;
If[dataChunk === {}, Break[]];
ic = Join[ic, Rest#getIC[dataChunk] + Last#ic];
jr = Join[jr, getJR[dataChunk]];
sparseData = Join[sparseData, getSparseData[dataChunk]];
dims[[1]] += First[Dimensions[dataChunk]];
];
makeSparseArray[dims, ic, jr, sparseData]];
Putting it all together
This function is the main one, putting it all together:
ClearAll[sparseArrayOuter];
sparseArrayOuter[f_, a_SparseArray, b_SparseArray, chunkSize_: 100] :=
Module[{next, wrapperF, getDataChunkCode},
make2DIndexInterator[next, Length#a, Length#b];
wrapperF[x_List, y_List] := SparseArray[f ### Transpose[{x, y}]];
getDataChunkCode :=
With[{inds = next[chunkSize]},
If[inds === Null, Return[{}]];
wrapperF[a[[#]] & /# inds[[All, 1]], b[[#]] & /# inds[[All, -1]]]
];
accumulateSparseArray[Hold[getDataChunkCode]]
];
Here, we first produce the iterator which will give us on demand portions of index pair list, used to extract the elements (also SparseArrays). Note that we will generally extract more than one pair of elements from two large input SparseArray-s at a time, to speed up the code. How many pairs we process at once is governed by the optional chunkSize parameter, which defaults to 100. We then construct the code to process these elements and put the result back into SparseArray, where we use an auxiliary function wrapperF. The use of iterators wasn't absolutely necessary (could use Reap-Sow instead, as with other answers), but allowed me to decouple the logic of iteration from the logic of generic accumulation of sparse arrays.
Benchmarks
First we prepare large sparse arrays and test our functionality:
In[49]:=
arr = {SparseArray[{{1,1,1,1}->1,{2,2,2,2}->1}],SparseArray[{{1,1,1,2}->1,{2,2,2,1}->1}],
SparseArray[{{1,1,2,1}->1,{2,2,1,2}->1}],SparseArray[{{1,1,2,2}->-1,{2,2,1,1}->1}],
SparseArray[{{1,2,1,1}->1,{2,1,2,2}->1}],SparseArray[{{1,2,1,2}->1,{2,1,2,1}->1}]};
In[50]:= list=SparseArray[arr]
Out[50]= SparseArray[<12>,{6,2,2,2,2}]
In[51]:= larger = sparseArrayOuter[Dot,list,list]
Out[51]= SparseArray[<72>,{36,2,2,2,2,2,2}]
In[52]:= (large= sparseArrayOuter[Dot,larger,larger])//Timing
Out[52]= {0.047,SparseArray[<2592>,{1296,2,2,2,2,2,2,2,2,2,2}]}
In[53]:= SparseArray[Flatten[Outer[Dot,larger,larger,1],1]]==large
Out[53]= True
In[54]:= MaxMemoryUsed[]
Out[54]= 21347336
Now we do the power tests
In[55]:= (huge= sparseArrayOuter[Dot,large,large,2000])//Timing
Out[55]= {114.344,SparseArray[<3359232>,{1679616,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2}]}
In[56]:= MaxMemoryUsed[]
Out[56]= 536941120
In[57]:= ByteCount[huge]
Out[57]= 262021120
In[58]:= (huge1 = Flatten[Outer[Dot,large,large,1],1]);//Timing
Out[58]= {8.687,Null}
In[59]:= MaxMemoryUsed[]
Out[59]= 2527281392
For this particular example, the suggested method is 5 times more memory-efficient than the direct use of Outer, but about 15 times slower. I had to tweak the chunksize parameter (default is 100, but for the above I used 2000, to get the optimal speed / memory use combination). My method only used as a peak value twice as much memory as needed to store the final result. The degree of memory-savings as compared to Outer- based method will depend on the sparse arrays in question.
If lst1 and lst2 are your lists,
Reap[
Do[Sow[f[#1[[i]], #2[[j]]]],
{i, 1, Length##1},
{j, 1, Length##2}
] &[lst1, lst2];
] // Last // Last
does the job and may be more memory-efficient. On the other hand, maybe not. Nasser is right, an explicit example would be useful.
EDIT: Using Nasser's randomly-generated arrays, and for len=200, MaxMemoryUsed[] indicates that this form needs 170MB while the Outer form in the question takes 435MB.
Using your example list data, I believe that you will find the ability to Append to a SparseArray quite helpful.
acc = SparseArray[{}, {1, 2, 2, 2, 2, 2, 2}]
Do[AppendTo[acc, i.j], {i, list}, {j, list}]
Rest[acc]
I need Rest to drop the first zero-filled tensor in the result. The second argument of the seed SparseArray must be the dimensions of each of your elements with a prefixed 1. You may need to explicitly specify a background for the seed SparseArray to optimize performance.
I want to repeat a function n times on a table, For n=2 I have the following code, How can I be sure that the function had run twice since my fc is differend every time?
smat = Table[{9, 8, 10}, {3}]
f[x_?Table] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #, {2, 2} -> x[[2]][[2]] + #}] &# fc[x[[2]][[1]]];
fc[k_?NumericQ] := Count[RandomReal[{0, 1}, k], x_ /; x < .1]
Nest[f, smat, 2]
This is probably what you want:
smat = Table[{9, 8, 10}, {3}]
ClearAll[f, fc];
f[x_List] :=
ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #, {2, 2} -> x[[2]][[2]] + #}] &#
fc[x[[2]][[1]]];
fc[k_?NumericQ] := Count[RandomReal[{0, 1}, k], x_ /; x < .1]
Nest[f, smat, 2]
ClearAll clears any previous definitions for those symbols (just in case). f[x_?Table] won't work; you want f[x_List], which means that the argument has a List head (Table is not a Head, and ? isn't what you want here).
I am not sure I have really answered your question though...
EDIT: To be clear, f[x_?something] means "apply something to x and, if it returns True, evaluate the right hand side of the := that follows. Look up PatternTest in Mathematica's documentation for more.
Acl covered the problems with the code pretty well, so I won't. To answer your question, though, I'd first separate your functions f and fc in separate cells, with fc being declared prior to f, and preface each cell with Clear[<function name>]. Now, to test if f is being applied twice, temporarily replace fc with
fc[_]:= a
or use another "dummy" value other than a, but it should be symbolic to increase readability. As a point of note, {1,2,3} + a == {1 + a, 2 + a, 3 + a}, so if f is applied twice, each term in x[[2]][[1]] and x[[2]][[2]] will have 2 a added to it.
Now, if you are unsure if fc is working correctly by itself, I'd apply it to a number separate cases without f, first.
I have the following Nested table
(myinputmatrix = Table[Nest[function, myinputmatrix[[i]][[j]],
myinputmatrix[[i]][[j]][[2]][[2]] +
myinputmatrix[[i]][[j]][[3]][[2]]], {i,
Dimensions[myinputmatrix][[1]]}, {j,
Dimensions[myinputmatrix][[2]]}]) // TableForm
fq[k_?NumericQ] := Count[RandomReal[{0, 1}, k], x_ /; x < .1]
function[x_List] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #1,
{2, 2} -> x[[2]][[2]] + #1,
{3, 1} -> x[[3]][[1]] - #2, {3, 2} ->
x[[3]][[2]] + #2}] &[fq[x[[2]][[1]]], fq[x[[2]][[1]]]];
My problem is that I want to add only the #1 in the bold part above, but not only the new one, I want it to add all #1 for the n times (Nest function times]
If I try the function
function[x_List] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #1, {2, 2} -> #1,
{3, 1} -> x[[3]][[1]] - #2, {3, 2} -> #2}] &[fq[x[[2]][[1]]],
fq[x[[2]][[1]]]];
I am having as a result the last value of fq[k]. I thought of replacing that part in my table with 0 but is not going to work since I am using it in my nested list, also I thought of substricting that part from my initial table but I am not sure which way is the best to do it and if the way I am thinking is the correct one. Can anyone help me?
If I may restate the problem and hopefully clarify the question for myself. At each iteration in the Nest, you want to add not the current (random) output from fq, but the cumulation of the current and all past values of it. But because the random output depends at each iteration on the input matrix, you need to calculate both the random number and the current value of the matrix in the same iteration.
If that hadn't been true you could use Fold.
Restating fq as Sasha suggested EDIT with some type checking to avoid problems with incorrect input:
fq[k_Integer?Positive]:=RandomVariate[BinomialDistribution[k,.1]]
You might want to add some other error checking code. Something like this, depending on your requirements, might do.
fq[0]:= 0;
fq[k_Real?Positive]:=RandomVariate[BinomialDistribution[Round[k],.1]]
You need function to take the random numbers as parameters. EDIT 1 and 2 I have changed the syntax of this function to use the parameters explicitly instead of the original question's anonymous function within a function. This should avoid some syntax errors. Also note that I have used "NumericQ" rather than "Real" as the type for the rv1 and rv2 parameters, because they can be integers at the start of the Nest iteration.
function[x_List, rv1_?NumericQ, rv2_?NumericQ] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - rv1, {2, 2} -> rv1,
{3, 1} -> x[[3]][[1]] - rv2, {3, 2} -> rv2}]
And then pass the current random number as a local constant using With to a Nest function that works on a list containing your matrix and the cumulation of the random variates. I have used myoutputmatrix because I really don't like the idea of rewriting existing expressions all the time. That's just me. Now, the one other thing is that you need to set n, the number of iterates. I've set it to 5 but you can make this a parameter in a function if you want (see below).
(myoutputmatrix = Table[ First[Nest[With[{rv=fq[#1[[1]][[2]][[1]] ]},
{function[#1[[1]],rv, rv+#1[[2]] ],rv+#1[[2]] }]&,
{ myinputmatrix[[i]][[j]], 0 }, 5]],
{i, Dimensions[myinputmatrix][[1]]}, {j,
Dimensions[myinputmatrix][[2]]}]) // TableForm
The First is there because in the end you only want the matrix, not the cumulation of the random variates.
outputmatrix[input_List, n_Integer?Positive] /;
Length[Dimensions[input]] == 4 :=
Table[First[
Nest[With[{rv = fq[#1[[1]][[2]][[1]]]}, {function[#1[[1]], rv,
rv + #1[[2]]], rv + #1[[2]]}] &, {input[[i]][[j]], 0}, n]],
{i, Dimensions[input][[1]]}, {j, Dimensions[input][[2]]}]
outputmatrix[myinputmatrix, 10] // TableForm
EDIT I have checked this now and it runs, but note that you can get negative numbers in the output, which is not what you want, I don't think.
How do I loop this?
p = Table[RandomChoice[{Heads, Tails}, 2 i + 1], {i, 10}];
v = Count[#, Heads] & /# p;
c = Count[#, Tails] & /# p;
f = Abs[v - c];
g = Take[f, LengthWhile[f, # != 3 &] + 1]
Thanks!
EDIT
In this coin flipping game the rules are as follows :
A single play consists of repeatedly
flipping a fair coin until the
difference between the number of
heads tossed and the number of tails
is three.
You must pay $1 each time the coin is
flipped, and you may not quit during
the play of the game.
You receive $8 at the end of each
play of the game.
Should you play this game?
How much might you expect to win or
lose after 500 plays?
You may use a spreadsheet simulation and/or reasoning about probabilities to answer these questions.
The class is using Excel, I'm trying to learn Mathematica.
A little bit more on the theoretical side
Your game is a random walk on R1.
As such, the expectancy value for the number of flips to get a distance of 3 is 32=9, and that is also the expectancy value for your cost.
As your earning per game is $8, you'll lose at a mean rate of $1 per game.
Note that these figures are consistent with #Mr. Wizard's result of 135108 - 120000 = 15108 for 15000 games.
If I understand the rules of the coin flipping game, and if you must use a Monte Carlo method, consider this:
count =
Table[
i = x = 0;
While[Abs[x] < 3, x += RandomChoice[{1, -1}]; i++];
i,
{15000}
];
The idea is to flip a coin until one person is winning by three, and then output the number of turns it took to get there. Do this 15,000 times, and create a list of the results (count).
The money you spent to play 15,000 games is simply the number of turns that were played, or:
Total # count
(* Out= 135108 *)
While your winnings are $8 * 15,000 = $120,000, so this is not a good game to play.
If you need to count the number of times each number of turns comes up, then:
Sort # Tally # count
Not sure if this is the best way to accomplish what you want, but this should get you started. First, note that I changed the names Heads and Tails to lowercase (Heads is a built-in symbol...)---lowercase variable names are the best way to avoid this type of problem.
Remove[p, v, c, fun, f, g, head, tail];
fun[n_] :=
Do[
Block[
{p, v, c, f, g},
p = Table[RandomChoice[{head, tail}, 2 i + 1], {i, 10}];
v = Count[#, head] & /# p;
c = Count[#, tail] & /# p;
f = Abs[v - c];
g = Print[Take[f, LengthWhile[f, # != 3 &] + 1]]
],
{n}]
Simply enter the number of times you want to run the loop... fun[5] gives:
{1,1,1,1,5,3}
{3}
{1,1,5,1,5,1,3}
{3}
{1,5,3}
Note: because you'll probably want to do something with the output, using Table[] is probably better than Do[]. This will return a list of lists.
Remove[p, v, c, fun, f, g, head, tail];
fun[n_] :=
Table[
Block[
{p, v, c, f, g},
p = Table[RandomChoice[{head, tail}, 2 i + 1], {i, 10}];
v = Count[#, head] & /# p;
c = Count[#, tail] & /# p;
f = Abs[v - c];
g = Take[f, LengthWhile[f, # != 3 &] + 1]
],
{n}]
Nothing fancy!
A little more Mathematica-ish. No vars defined.
g[n_] := Table[(Abs /# Total /#
Array[RandomChoice[{-1, 1}, (2 # + 1)] &, 10]) /.
{x___, 3, ___} :> {x, 3},
{n}]
Credit to #Mr.Wizard for this answer.
g[2]
->{{1, 1, 1, 5, 5, 1, 5, 7, 3}, {1, 3}}
I don't like bitching about RTFM etc. but looping is pretty basic. If I type "loop" in the search box in the documentation center one of the first few hits contains a link to the page "guide/LoopingConstructs" and this contains a link to the tutorial "tutorial/LoopsAndControlStructures". Have you read these?