Related
I have a code where we first need to generate n + 1 numbers in a range with a given step. However, I don't understand how and why it works:
a = 2;
b = 7;
h = (b-a)/n;
x[0] = a;
Array[x, n+1, 0];
For[i = 0, i < n + 1, i++, x[i] = a + h*i]
My questions are:
Are elements of x automatically generated when accessed? There's no mention of x before the line x[0] = a
Shouldn't index access be like x[[i]]?
What exactly does Array do here? It isn't assigned to anything which confuses me
Try Range[2,10,2] for a range of numbers from 2 to 10 in steps of 2, etc.
Beyond that there some faults in your code, or perhaps in your understanding of Mathematica ...
x[0] = a defines a function called x which, when presented with argument 0 returns a (or a's value since it is previously defined). Mathematica is particular about the bracketing characters used [ and ] enclose function argument lists. Since there is no other definition for the function x (at least not that we can see here) then it will return unevaluated for any argument other than 0.
And you are right, doubled square brackets, ie [[ and ]], are used to enclose index values. x[[2]] would indeed refer to the second element of a list called x. Note that Mathematica indexes from 1 so x[[0]] would produce an error if x existed and was a list.
The expression Array[x, n+1, 0] does return a value, but it is not assigned to any symbol so is lost. And the trailing ; on the line suppresses Mathematica's default behaviour to print the return value of any expression you execute.
Finally, on the issue of the use of For to make lists of values, refer to https://mathematica.stackexchange.com/questions/7924/alternatives-to-procedural-loops-and-iterating-over-lists-in-mathematica. And perhaps ask further Mathematica questions at that site, the real experts on the system are much more likely to be found there.
I suppose I might add ... if you are committed to using Array for some reason ask another question specifically about that. As you might (not) realise, I recommend not using that function to create a list of numbers.
From the docs, Array[f, n, r] generates a list using the index origin r.
On its own Array[x, n + 1, 0] just produces a list of x functions, e.g.
n = 4;
Array[x, n + 1, 0]
{x[0], x[1], x[2], x[3], x[4]}
If x is defined it is applied, e.g.
x[arg_] := arg^2
Array[x, 4 + 1, 0]
{0, 1, 4, 9, 16}
Alternatively, to use x as a function variable the Array can be set like so
Clear[x]
With[{z = Array[x, n + 1, 0]}, z = {m, n, o, p, q}]
{x[0], x[1], x[2], x[3], x[4]}
{m, n, o, p, q}
The OP's code sets function variables of x in the For loop, e.g.
Still with n = 4
a = 2;
b = 7;
h = (b - a)/n;
For[i = 0, i < n + 1, i++, x[i] = a + h*i]
which can be displayed by Array[x, n + 1, 0]
{2, 13/4, 9/2, 23/4, 7}
also x[0] == 2
True
The same could be accomplished thusly
Clear[x]
With[{z = Array[x, n + 1, 0]}, z = Table[a + h*i, {i, 0, 4}]]
{2, 13/4, 9/2, 23/4, 7}
Note also DownValues[x] shows the function definitions
{HoldPattern[x[0]] :> 2,
HoldPattern[x[1]] :> 13/4,
HoldPattern[x[2]] :> 9/2,
HoldPattern[x[3]] :> 23/4,
HoldPattern[x[4]] :> 7}
I am new to Mathematica.
I have a lower triangular matrix defined as follow
A = Table[If[i > j, Subscript[a, i, j], 0], {i, s}, {j, s}];
I would like to the lower triangular elements in a list. For example, when s = 2, the list would contain listOfElement = {a_{2,1}} and for s = 3, listOfElement = {a_{2,1},a_{3,1},a_{3,2}}
How can I do this in Mathematica?
Thank you so much in advance
for example this
A = RandomReal[{0, 1}, {3, 3}];
MatrixForm[A]
M = First[Dimensions[A]];
Flatten[A[[# + 1 ;;, #]] & /# Range[M - 1]]
produces:
(0.586886 0.968229 0.543306
0.107212 0.0492116 0.103052
0.0569797 0.429895 0.70289
)
{0.107212,0.0569797,0.429895}
You can use Pick together with a selection matrix:
selectionMatrix = LowerTriangularize[ConstantArray[1, {s, s}], -1]
selectionMatrix is now a lower triangular matrix with ones where you want to Pick elements in A. You then get the elements of A like this:
listOfElements = Flatten # Pick[A, selectionMatrix, 1]
edit: Make sure you define s, of course.
This is an example. I want to know if there is a general way to deal with this kind of problems.
Suppose I have a function (a ε ℜ) :
f[a_, n_Integer, m_Integer] := Sum[a^i k[i],{i,0,n}]^m
And I need a closed form for the coefficient a^p. What is the better way to proceed?
Note 1:In this particular case, one could go manually trying to represent the sum through Multinomial[ ], but it seems difficult to write down the Multinomial terms for a variable number of arguments, and besides, I want Mma to do it.
Note 2: Of course
Collect[f[a, 3, 4], a]
Will do, but only for a given m and n.
Note 3: This question is related to this other one. My application is different, but probably the same methods apply. So, feel free to answer both with a single shot.
Note 4:
You can model the multinomial theorem with a function like:
f[n_, m_] :=
Sum[KroneckerDelta[m - Sum[r[i], {i, n}]]
(Multinomial ## Sequence#Array[r, n])
Product[x[i]^r[i], {i, n}],
Evaluate#(Sequence ## Table[{r[i], 0, m}, {i, 1, n}])];
So, for example
f[2,3]
is the cube of a binomial
x[1]^3+ 3 x[1]^2 x[2]+ 3 x[1] x[2]^2+ x[2]^3
The coefficient by a^k can be viewed as derivative of order k at zero divided by k!. In version 8, there is a function BellY, which allows to construct a derivative at a point for composition of functions, out of derivatives of individual components. Basically, for f[g[x]] and expanding around x==0 we find Derivative[p][Function[x,f[g[x]]][0] as
BellY[ Table[ { Derivative[k][f][g[0]], Derivative[k][g][0]}, {k, 1, p} ] ]/p!
This is also known as generalized Bell polynomial, see wiki.
In the case at hand:
f[a_, n_Integer, m_Integer] := Sum[a^i k[i], {i, 0, n}]^m
With[{n = 3, m = 4, p = 7},
BellY[ Table[{FactorialPower[m, s] k[0]^(m - s),
If[s <= n, s! k[s], 0]}, {s, 1, p}]]/p!] // Distribute
(*
Out[80]= 4 k[1] k[2]^3 + 12 k[1]^2 k[2] k[3] + 12 k[0] k[2]^2 k[3] +
12 k[0] k[1] k[3]^2
*)
With[{n = 3, m = 4, p = 7}, Coefficient[f[a, n, m], a, p]]
(*
Out[81]= 4 k[1] k[2]^3 + 12 k[1]^2 k[2] k[3] + 12 k[0] k[2]^2 k[3] +
12 k[0] k[1] k[3]^2
*)
Doing it this way is more computationally efficient than building the entire expression and extracting coefficients.
EDIT The approach here outlined will work for symbolic orders n and m, but requires explicit value for p. When using it is this circumstances, it is better to replace If with its Piecewise analog, e.g. Boole:
With[{p = 2},
BellY[Table[{FactorialPower[m, s] k[0]^(m - s),
Boole[s <= n] s! k[s]}, {s, 1, p}]]/p!]
(* 1/2 (Boole[1 <= n]^2 FactorialPower[m, 2] k[0]^(-2 + m)
k[1]^2 + 2 m Boole[2 <= n] k[0]^(-1 + m) k[2]) *)
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}]
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?