Related
Ok! I'm working towards building a nested manipulate command that will solve n number of damped oscillating masses in series (with fixed endpoints). I have everything pretty much working but I have one problem - when I increase the number of oscillators, my initial conditions lag behind a bit. For example, if I set n to 4, Mathematica says I still only have 2 initial conditions (the starting number - position and velocity for one oscillator). When I then move to 3, I now have 8 (from my 4 oscillators) - which is too many for the state space equations, and it all fails. What is going on?
(Yes, I know that my initial conditions aren't going to be put in correctly yet, I'm just trying to get them to match up first).
coupledSMD[n_, m_, k_, b_, f_, x0_, v0_, tmax_] :=
Module[{aM, bM, cM, dM},
aM = Join[Table[Boole[i == j - n], {i, n}, {j, 2 n}],
Join[
If[n != 1,DiagonalMatrix[-2 k/m Table[1, {n}]] +
k/m DiagonalMatrix[Table[1, {n - 1}], 1] +
k/m DiagonalMatrix[Table[1, {n - 1}], -1],
{{-2 k/m}}],
If[n != 1,DiagonalMatrix[-2 b/m Table[1, {n}]] +
b/m DiagonalMatrix[Table[1, {n - 1}], 1] +
b/m DiagonalMatrix[Table[1, {n - 1}], -1],
{{-2 b/m}}], 2]];
bM = Join[Table[0, {n}, {1}], Table[1/m, {n}, {1}]];
cM = Table[Boole[i == j], {i, n}, {j, 2 n}];
dM = Table[0, {n}, {1}];
OutputResponse[
{StateSpaceModel[{aM, bM, cM, dM}], Flatten[Join[x0, v0]]},
f, {t, 0, tmax}]
]
Manipulate[
With[{
x0s = Table[Subscript[x, i, 0], {i, 1, n}],
v0s = Table[Subscript[v, i, 0], {i, 1, n}],
initialx = Sequence ## Table[{{Subscript[x, i, 0], 0}, -10, 10}, {i, 1, n}],
initialv = Sequence ## Table[{{Subscript[v, i, 0], 0}, -10, 10}, {i, 1, n}]},
Manipulate[
myplot = coupledSMD[n, m, k, b, f, x0s, v0s, tmax];
Plot[myplot, {t, 0, tmax}, PlotRange -> yheight {-1, 1},
PlotLegends -> Table[Subscript[x, i, 0], {i, 1, n}]],
Style["Initial Positions", Bold],
initialx,
Delimiter,
Style["Initial Velocities", Bold],
initialv,
Delimiter,
Style["System conditions", Bold],
{{m, 1, "Mass(kg)"}, 0.1, 10, Appearance -> "Labeled"},
{{k, 1, "Spring Constant(N/m)"}, 0.1, 10, Appearance -> "Labeled"},
{{b, 0, "Damping Coefficient(N.s/m)"}, 0, 1, Appearance -> "Labeled"},
{{f, 0, "Applied Force"}, 0, 10, Appearance -> "Labeled"},
Delimiter,
Style["Plot Ranges", Bold],
{tmax, 10, 100},
{{yheight, 10}, 1, 100},
Delimiter,
ControlPlacement -> Flatten[{Table[Right, {2 n + 2}], Table[Left, {8}]}]
]],
{n, 1, 4, 1}
]
Edit: Updated the code. It works now, but I'm still getting the errors. I'm guessing that it has something to do with a time lag in the updating process? - That some parts are getting updated before others. Again, it seems to be working perfectly, except it throws these errors (the errors seem superfluous to me, as if they are remnants in the code, but not actually causing a problem)
But I don't really know what I'm talking about :)
I am using Mathematica version 5.2. I need to split it to function, and make a result..
I've created this monster:
mx = {};
arg = {};
fun = {};
x =.
y =.
here are lists and arguments
switchfunction2[y_] := Switch[y,
1, AppendTo[fun, Cos[Random[Integer, {1, 10}]]],
2, AppendTo[fun, Sin[Random[Integer, {1, 10}]]],
3, AppendTo[fun, Tan[Random[Integer, {1, 10}]]],
4, AppendTo[fun, Csc[Random[Integer, {1, 10}]]],
5, AppendTo[fun, Sec[Random[Integer, {1, 10}]]],
6, AppendTo[fun, Cot[Random[Integer, {1, 10}]]]
]
and random functions
Do[AppendTo[mx, Random[Integer, {1, 10}]], {i, 2}]
mx[[1]] " has been chosed"
mx[[2]] "argumments "
Do[AppendTo[arg, Random[Integer, {1, 5}]], {i, mx[[2]]}]
arg
Do[switchfunction2 /# {arg[[i]]}, {i, mx[[2]]}]
fun
I want to obtain f[z_]:=fun[[1]]+fun[[2]]...
In this case, I would do something like
mx = RandomInteger[{1, 10}, 2];
arg = RandomInteger[{1, 5}, mx[[2]]];
switch[y_] := Module[{f},
f = Switch[y, 1, Cos, 2, Sin, 3, Tan, 4, Csc, 5, Sec, 6, Cot];
f[RandomInteger[{1, 10}]]]
fun = switch /# arg;
Total[fun]
Or without using a switch function:
mx = RandomInteger[{1, 10}, 2]
flist = RandomChoice[{Cos, Sin, Tan, Csc, Sec, Cot}, mx[[2]]];
fun = #[RandomInteger[{1, 10}]] & /# flist;
Total[fun]
Edit
Here's a version that should work in Mathematica 5.2.
mx = Table[Random[Integer, {1, 10}], {2}];
arg = Table[Random[Integer, {1, 5}], {mx[[2]]}];
switch[y_] := Module[{f},
f = Switch[y, 1, Cos, 2, Sin, 3, Tan, 4, Csc, 5, Sec, 6, Cot];
f[Random[Integer, {1, 10}]]]
fun = switch /# arg;
Total[fun]
To make a function out of this you could wrap everything in a Module, e.g.
f := Module[{mx, arg, switch},
mx = Random[Integer, {1, 10}];
arg = Table[Random[Integer, {1, 5}], {mx}];
switch[y_] := Module[{f},
f = Switch[y, 1, Cos, 2, Sin, 3, Tan, 4, Csc, 5, Sec, 6, Cot];
f[Random[Integer, {1, 10}]]];
Total[switch /# arg]]
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];
I have a list of expressions that operate on data.
Min[data]
Max[data]
Covariance[data, data1]
Mean[data]
GeometricMean[data]
Total[data]
Sum[Log[data[[i]]], {i, 1, Length[data]}]
Sum[(data[[i]])^2, {i, 1, Length[data]}]
The output looks like this
Out[1]= 1.9
Out[2]= 3.1
....
Is it possible to show the result along with its expression? For example
Min[data] = 1.9
Max[data] = 3.1
....
Any advice on how to format that kind of output for easy reading is welcome!
You could use
$PrePrint =
Function[a,
Row[{ToExpression[InString[$Line], StandardForm, HoldForm], " = ",
a}]];
which is fine for small inputs, but perhaps not what you want for multiline inputs.
(You can turn this off again with Unset[$PrePrint])
data = {1, 2, 3, 4};
data1 = {2, 1, 4, 3};
ClearAll[exprShowAndEvaluate];
SetAttributes[exprShowAndEvaluate, {HoldAll, Listable}];
exprShowAndEvaluate[expr_] := Print[HoldForm[expr], "=", expr];
exprShowAndEvaluate[{Min[data],
Max[data],
Covariance[data, data1],
Mean[data],
GeometricMean[data],
Total[data],
Sum[Log[data[[i]]], {i, 1, Length[data]}],
Sum[(data[[i]])^2, {i, 1, Length[data]}]}];
(* output ==>
*)
Update
In his comment below Usavich, indicated he wants to pass a list of these expressions assigned to a variable to the function. This is not directly possible as the expressions evaluate in the process:
expr =
{
Min[data], Max[data], Covariance[data, data1], Mean[data],
GeometricMean[data], Total[data],
Sum[Log[data[[i]]], {i, 1, Length[data]}],
Sum[(data[[i]])^2, {i, 1, Length[data]}]
}
(* Output ==>
{1, 4, 1, 5/2, 2^(3/4) 3^(1/4), 10, Log[2] + Log[3] + Log[4], 30}
*)
You have to Hold the expression list before assigning:
expr =
Hold[
{
Min[data], Max[data], Covariance[data, data1], Mean[data],
GeometricMean[data], Total[data],
Sum[Log[data[[i]]], {i, 1, Length[data]}],
Sum[(data[[i]])^2, {i, 1, Length[data]}]
}
]
With a new version of exprShowAndEvaluate we can process expr:
ClearAll[exprShowAndEvaluate];
exprShowAndEvaluate[expr_Hold] :=
Module[{tempExpr},
tempExpr = ReleaseHold[Map[HoldForm, expr, {2}]];
Print[#1, "=", ReleaseHold[#1]] & /# tempExpr
];
The function can now be called with the held list:
exprShowAndEvaluate[expr]
Results as before.
As a sidebar, you have two functions that can be simplified:
Sum[Log[data[[i]]], {i, 1, Length[data]}]
Sum[(data[[i]])^2, {i, 1, Length[data]}]
Since version 6, these can be written more concisely and readably:
Sum[Log[i], {i, data}]
Sum[i^2, {i, data}]
I'm writing a game of life program in mathematica however there is a caveat in that I need to be able to apply the reproduction rules to some percentage of the cells, I want to try a new method using MapAt but liveNeighbors doesn't work elementwise, and I can't think of a way of fixing it without doing exactly what I did before (lots of messy indexing), does anyone have any suggestions? (I am assuming this will be more efficient then the old method, which is listed below, if not please let me know, I am just a beginner!).
What I am trying to do:
Map[ArrayPlot,FixedPointList[MapAt[update[#,liveNeighbors[#]]&,#,coords]&,Board, 1]]
What I have done already:
LifeGame[ n_Integer?Positive, steps_] := Module [{Board, liveNeighbors, update},
Board = Table [Random [Integer], {n}, {n}];
liveNeighbors[ mat_] :=
Apply[Plus,Map[RotateRight[mat,#]&,{{-1,-1},{-1, 0},{-1,1}, {0, -1}, {0, 1}, {1, -1}, {1, 0}, {1, 1}}]];
update[1, 2] := 1;
update[_, 3] := 1;
update[ _, _] := 0;
SetAttributes[update, Listable];
Seed = RandomVariate[ProbabilityDistribution[0.7 UnitStep[x] + 0.3 UnitStep[x - 1], {x, 0, 1, 1}], {n, n}];
FixedPointList[Table[If[Seed[[i, j]] == 1,update[#[[i, j]], liveNeighbors[#][[i, j]]],#[[i, j]]], {i, n}, {j, n}]&, Board, steps]]]
Thanks!
In[156]:=
LifeGame2[n_Integer?Positive, steps_] :=
Module[{Board, liveNeighbors, update},
Board = RandomInteger[1, {n, n}];
liveNeighbors[mat_] :=
ListConvolve[{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}},
ArrayPad[mat, 1, "Periodic"]];
SetAttributes[update, Listable];
Seed = RandomVariate[BernoulliDistribution[0.3], {n, n}];
update[0, el_, nei_] := el;
update[1, 1, 2] := 1;
update[1, _, 3] := 1;
update[1, _, _] := 0;
FixedPointList[MapThread[update, {Seed, #, liveNeighbors[#]}, 2] &,
Board, steps]
]
This implementation does the same as yours, except is quite a lot faster:
In[162]:= AbsoluteTiming[
res1 = BlockRandom[SeedRandom[11]; LifeGame[20, 100]];]
Out[162]= {6.3476347, Null}
In[163]:= Timing[BlockRandom[Seed[11]; LifeGame2[20, 100]] == res1]
Out[163]= {0.047, True}
Assuming you don't have to roll your own code for a homework problem, have you considered just using the built-in CellularAutomaton function?
Straight from the documentation, the 2D CA rule:
GameOfLife = {224, {2, {{2, 2, 2}, {2, 1, 2}, {2, 2, 2}}}, {1, 1}};
And iterate over a 100x100 grid for 100 steps:
ArrayPlot[CellularAutomaton[GameOfLife, RandomInteger[1, {100, 100}], {{{100}}}]]
It would at least give you a baseline for a speed comparison.
Instead of MapAt, you could use Part with the Span syntax to replace a whole subarray at once:
a = ConstantArray[0, {5, 5}];
a[[2 ;; 4, 2 ;; 4]] = {{1, 2, 3}, {4, 5, 6}, {7, 8, 9}}
HTH!
Here you have my golfed version.