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 have wirtten the following code. It is a code for mathematica and I would like to do some "simple" linear algebra with symbols.
The code sets up a matrix (called A) and a vector (called b). Then it solves the euqation A*k=b for k.
Unfortunately, my code is super slow, e.g. for n=5 it takes hours.
Is there any better way for solving this problem? I am not that familiar with mathematica and my code is rather unprofessional, so do you have any hints for speeding things up?
Here is my code.
clear[all];
n = 3;
MM = Table[Symbol["M" <> ToString#i], {i, 1, n}];
RB = Table[
Symbol["RA" <> FromCharacterCode[65 + i] <> ToString#(i + 1)], {i,
1, n - 1}];
mA = Table[Symbol["mA" <> FromCharacterCode[65 + i]], {i, 1, n - 1}];
mX = Table[
Symbol["m" <> FromCharacterCode[65 + i] <> "A"], {i, 1, n - 1}];
R = Table[
Symbol["R" <> FromCharacterCode[64 + i] <> ToString#(j + 1)], {i,
1, n}, {j, 1, n - 1}];
b = Table[-MM[[1]]*(1/(mA[[i]]*(R[[1, i]] - RB[[i]])) -
1/(mX[[i]]*(-R[[i + 1, i]] + RB[[i]]))), {i, 1, n - 1}];
A = Table[
MM[[j + 1]]*(R[[1, j]]/(mA[[i]]*(R[[1, i]] - RB[[i]])) -
R[[i + 1, j]]/(mX[[i]]*(-R[[i + 1, i]] + RB[[i]]))), {i, 1,
n - 1}, {j, 1, n - 1}];
K = LinearSolve[A, b];
MatrixForm[K]
Thanks for any hints!
P.S. The code should run!
You have lots of variables and lots of denominators, both of which can often make things very slow.
Let's try a simpler faster method that solves a generic form of your problem and then substitutes in all your variables and denominators.
n = 5;
MM = ...
...
A = ...
m={{m1,m2,m3,m4},{m5,m6,m7,m8},{m9,m10,m11,m12},{m13,m14,m15,m16}};
sol=Inverse[m].b/.Thread[Rule[Flatten[m],Flatten[A]]]
which gives a solution in fraction of a second. But you need to carefully check this to justify that there are no zero denominators hiding in your problem or this solution.
This method is faster than Inverse[A].b and far faster than LinearSolve[A, b] for your problem, but that time is only for the calculation of the solution and does not include any potentially large amount of time spent using the solution. It also does not include any of the programming hidden inside LinearSolve to deal with potential problems and special cases.
But I am not certain as your n grows larger and your forest of denominators grows far larger that this will continue to be fast or feasible.
Test this carefully before you assume everything works.
P.S. Thank you for the code that actually ran! (I didn't even use the clear[all])
I am trying to learn a little bit about Wolfram Mathematica.
I want to define a symbolic function
where x is a vector, g is a function that takes a vector and returns a vector and h is a function that takes a vector and returns a scalar.
I don't want to commit to specific g and h, I just want to have a symbolic representation for them.
I would like to get a symbolic form for the third order derivatives (which would be a tensor) -- is there a way to do that in Wolfram Mathematica?
EDIT: I should mention, A and C are matrices, and b and d are vectors.
Here is what I tried and didn't work:
Try this
f[x_] := x*E^x
and then this
f'[x]
returns this
E^x + E^x x
and this
f''[x]
returns this
2 E^x + E^x x
Three methods of notation, all producing the same result.
f[x_] := Sin[x] + x^2
D[f[x], x]
2 x + Cos[x]
f'[x]
2 x + Cos[x]
f''[x]
2 - Sin[x]
using an alternative form of definition of f
Clear[f]
f = Sin[x] + x^2
D[f, x]
2 x + Cos[x]
δx f
2 x + Cos[x]
δ{x,2} f
2 - Sin[x]
Note
δ{x,2} f is supposed to be the subscript form of D[f, {x, 2}] but web formatting is limited.
Scoping out matrix and vector dimensions, and using S instead of C since the latter is a protected (uppercase) symbol.
A = {{1, 2, 3}, {4, 5, 6}};
x = {2, 4, 8};
A.x
{34, 76}
b = {3, 5};
h = 3;
h (A.x + b)
{111, 243}
S = {{1, 2}, {3, 4}, {5, 6}};
S.(h (A.x + b))
{597, 1305, 2013}
d = {2, 4, 8};
g = 2;
g (S.(h (A.x + b)) + d)
{1198, 2618, 4042}
So compatible matrix and vector assumptions can be made. (It turns out the derivative result comes out the same without taking the trouble to make the assumptions.)
Clear[A, x, b, S, d]
$Assumptions = {
Element[A, Matrices[{m, n}]],
Element[x, Vectors[n]],
Element[b, Vectors[m]],
Element[S, Matrices[{n, m}]],
Element[d, Vectors[n]]};
f = g (S.(h (A.x + b)) + d);
D[f, x]
g S.(h A.1)
D[f, {x, 3}]
0
I'm not sure if these results are correct so if you find out do comment.
I need to create a 3 by 3 real orthonormal symbolic matrix in Mathematica.
How can I do so?
Not that I recommend this, but...
m = Array[a, {3, 3}];
{q, r} = QRDecomposition[m];
q2 = Simplify[q /. Conjugate -> Identity]
So q2 is a symbolic orthogonal matrix (assuming we work over reals).
You seem to want some SO(3) group parametrization in Mathematica I think. You will only have 3 independent symbols (variables), since you have 6 constraints from mutual orthogonality of vectors and the norms equal to 1. One way is to construct independent rotations around the 3 axes, and multiply those matrices. Here is the (perhaps too complex) code to do that:
makeOrthogonalMatrix[p_Symbol, q_Symbol, t_Symbol] :=
Module[{permute, matrixGeneratingFunctions},
permute = Function[perm, Permute[Transpose[Permute[#, perm]], perm] &];
matrixGeneratingFunctions =
Function /# FoldList[
permute[#2][#1] &,
{{Cos[#], 0, Sin[#]}, {0, 1, 0}, {-Sin[#], 0, Cos[#]}},
{{2, 1, 3}, {3, 2, 1}}];
#1.#2.#3 & ## MapThread[Compose, {matrixGeneratingFunctions, {p, q, t}}]];
Here is how this works:
In[62]:= makeOrthogonalMatrix[x,y,z]
Out[62]=
{{Cos[x] Cos[z]+Sin[x] Sin[y] Sin[z],Cos[z] Sin[x] Sin[y]-Cos[x] Sin[z],Cos[y] Sin[x]},
{Cos[y] Sin[z],Cos[y] Cos[z],-Sin[y]},
{-Cos[z] Sin[x]+Cos[x] Sin[y] Sin[z],Cos[x] Cos[z] Sin[y]+Sin[x] Sin[z],Cos[x] Cos[y]}}
You can check that the matrix is orthonormal, by using Simplify over the various column (or row) dot products.
I have found a "direct" way to impose special orthogonality.
See below.
(*DEFINITION OF ORTHOGONALITY AND SELF ADJUNCTNESS CONDITIONS:*)
MinorMatrix[m_List?MatrixQ] := Map[Reverse, Minors[m], {0, 1}]
CofactorMatrix[m_List?MatrixQ] := MapIndexed[#1 (-1)^(Plus ## #2) &, MinorMatrix[m], {2}]
UpperTriangle[ m_List?MatrixQ] := {m[[1, 1 ;; 3]], {0, m[[2, 2]], m[[2, 3]]}, {0, 0, m[[3, 3]]}};
FlatUpperTriangle[m_List?MatrixQ] := Flatten[{m[[1, 1 ;; 3]], m[[2, 2 ;; 3]], m[[3, 3]]}];
Orthogonalityconditions[m_List?MatrixQ] := Thread[FlatUpperTriangle[m.Transpose[m]] == FlatUpperTriangle[IdentityMatrix[3]]];
Selfadjunctconditions[m_List?MatrixQ] := Thread[FlatUpperTriangle[CofactorMatrix[m]] == FlatUpperTriangle[Transpose[m]]];
SO3conditions[m_List?MatrixQ] := Flatten[{Selfadjunctconditions[m], Orthogonalityconditions[m]}];
(*Building of an SO(3) matrix*)
mat = Table[Subscript[m, i, j], {i, 3}, {j, 3}];
$Assumptions = SO3conditions[mat]
Then
Simplify[Det[mat]]
gives 1;...and
MatrixForm[Simplify[mat.Transpose[mat]]
gives the identity matrix;
...finally
MatrixForm[Simplify[CofactorMatrix[mat] - Transpose[mat]]]
gives a Zero matrix.
========================================================================
This is what I was looking for when I asked my question!
However, let me know your thought on this method.
Marcellus
Marcellus, you have to use some parametrization of SO(3), since your general matrix has to reflect the RP3 topology of the group. No single parametrization will cover the whole group without either multivaluedness or singular points. Wikipedia has a nice page about the various charts on SO(3).
Maybe one of the conceptually simplest is the exponential map from the Lie algebra so(3).
Define an antisymmetric, real A (which spans so(3))
A = {{0, a, -c},
{-a, 0, b},
{c, -b, 0}};
Then MatrixExp[A] is an element of SO(3).
We can check that this is so, using
Transpose[MatrixExp[A]].MatrixExp[A] == IdentityMatrix[3] // Simplify
If we write t^2 = a^2 + b^2 + c^2, we can simplify the matrix exponential down to
{{ b^2 + (a^2 + c^2) Cos[t] , b c (1 - Cos[t]) + a t Sin[t], a b (1 - Cos[t]) - c t Sin[t]},
{b c (1 - Cos[t]) - a t Sin[t], c^2 + (a^2 + b^2) Cos[t] , a c (1 - Cos[t]) + b t Sin[t]},
{a b (1 - Cos[t]) + c t Sin[t], a c (1 - Cos[t]) - b t Sin[t], a^2 + (b^2 + c^2) Cos[t]}} / t^2
Note that this is basically the same parametrization as RotationMatrix gives.
Compare with the output from
RotationMatrix[s, {b, c, a}] // ComplexExpand // Simplify[#, Trig -> False] &;
% /. a^2 + b^2 + c^2 -> 1
Although I really like the idea of Marcellus' answer to his own question, it's not completely correct. Unfortunately, the conditions he arrives at also result in
Simplify[Transpose[mat] - mat]
evaluating to a zero matrix! This is clearly not right. Here's an approach that's both correct and more direct:
OrthogonalityConditions[m_List?MatrixQ] := Thread[Flatten[m.Transpose[m]] == Flatten[IdentityMatrix[3]]];
SO3Conditions[m_List?MatrixQ] := Flatten[{OrthogonalityConditions[m], Det[m] == 1}];
i.e. multiplying a rotation matrix by its transpose results in the identity matrix, and the determinant of a rotation matrix is 1.
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}]