Mathematica Nested Manipulates Lag - wolfram-mathematica

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 :)

Related

Manipulate does not accept constant (i.e. just number) as upper limit for variable

In the code below, If I chenage (4/([Zeta]*[Omega])) to, say 20, nothing is plotted. Why?
If I remove the two sliders at the beginning, nothing is plotted
ClearAll[\[Zeta], \[Omega]]
{Slider[ Dynamic[\[Zeta]], {0.1, 1.4, 0.1}], Dynamic[\[Zeta]]}
{Slider[ Dynamic[\[Omega]], {1, 5, 0.1}], Dynamic[\[Omega]]}
tf[\[Omega]_, \[Zeta]_] :=
TransferFunctionModel[\[Omega]^2/(s^2 +
2 \[Zeta] \[Omega] s + \[Omega]^2), s]
f[t_] = OutputResponse[tf[\[Omega], \[Zeta]], UnitStep[t], t];
Manipulate[
Plot[f[t], {t, 0, (4/(\[Zeta]*\[Omega]))},
PlotRange -> {{0, (4/(\[Zeta]*\[Omega]))}, {0, 2}}], {{\[Zeta],
0.2}, 0.1, 1.4}, {{\[Omega], 1}, 0.5, 4}
]
tf[o_, z_] := TransferFunctionModel[o^2/(s^2 + 2 z o s + o^2), s]
f[t_, o_, z_] = OutputResponse[tf[o, z], UnitStep[t], t];
Manipulate[Plot[f[t, o, z], {t, 0, 20}, PlotRange -> {0, 2}],
{{z, 0.2}, 0.1, 1.4}, {{o, 1}, 0.5, 4}]

How to shade a plot in Mathematica

I want to generate a plot like the following
I am not sure how to generate a shading even though I can get the frame done. I'd like to know the general approach to shade certain areas in a plot in Mathematica. Please help. Thank you.
Perhaps you are looking for RegionPlot?
RegionPlot[(-1 + x)^2 + (-1 + y)^2 < 1 &&
x^2 + (-1 + y)^2 < 1 && (-1 + x)^2 + y^2 < 1 && x^2 + y^2 < 1,
{x, 0, 1}, {y, 0, 1}]
Note the use of op_ in the following (only one set of equations for the curves and the intersection!):
t[op_] :=Reduce[op[(x - #[[1]])^2 + (y - #[[2]])^2, 1], y] & /# Tuples[{0, 1}, 2]
tx = Texture[Binarize#RandomImage[NormalDistribution[1, .005], 1000 {1, 1}]];
Show[{
Plot[y /. ToRules /# #, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}] &# t[Equal],
RegionPlot[And ## #, {x, 0, 1}, {y, 0, 1}, PlotStyle -> tx] &# t[Less]},
Frame->True,AspectRatio->1,FrameStyle->Directive[Blue, Thick],FrameTicks->None]
If, for any particular reason, you want the dotted effect in your picture, you can achieve this like so:
pts = RandomReal[{0, 1}, {10000, 2}];
pts = Select[pts,
And ## Table[Norm[# - p] < 1, {p,
{{0, 0}, {1, 0}, {1, 1}, {0, 1}}}] &];
Graphics[{Thick,
Line[{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}}],
Circle[{0, 0}, 1, {0, Pi/2}],
Circle[{1, 0}, 1, {Pi/2, Pi}],
Circle[{1, 1}, 1, {Pi, 3 Pi/2}],
Circle[{0, 1}, 1, {3 Pi/2, 2 Pi}],
PointSize[Small], Point[pts]
}]

How to avoid asymptotes when I ListPlot a table of data using Mathematica?

I am plotting a table of data using ListPlot in Mathematica. I notice that there are a few asymptotes on the graph which I do not want it to be plotted (i.e. the straight lines between the curves). What should I do to remove the straight lines?
A method from Mark McClure's post here: How to annotate multiple datasets in ListPlots
t = Table[Tan[i], {i, -Pi, Pi, .01}];
plot = ListLinePlot[t];
DeleteCases[plot, Line[_?(Length[#] < 4 &)], Infinity]
Perhaps:
t = Table[Tan[i], {i, -Pi, Pi, .01}];
ListPlot[#, Joined -> True] & /# {t, t /. x_ /; Abs#x > 10 -> None}
Edit
More robust:
t = Table[Tan[i], {i, -Pi, Pi, .01}];
ao = AbsoluteOptions[ListPlot[t, Joined -> True],PlotRange]/. {_ -> {_,x_}} ->x;
ListPlot[t /. x_ /; (x < ao[[1]] || x > ao[[2]]) -> None, Joined -> True]
t = Table[Tan[i], {i, -Pi, Pi, .01}];
plot = ListLinePlot[t];
Using Position
Position[plot, Line[___], Infinity]
{{1, 1, 3, 2}, {1, 1, 3, 3}, {1, 1, 3, 4}, {1, 1, 3, 5}, {1, 1, 3, 6}}
Using Part:
plot[[1, 1, 3, 5 ;; 6]] = Sequence[]; Show[plot]

For loop to change the values of a four dimensional table

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];

in mathematica, how to make initial condition as a variable in ndsolve?

i'd like to have something like this
w[w1_] :=
NDSolve[{y''[x] + y[x] == 2, y[0] == w1, y'[0] == 0}, y, {x, 0, 30}]
this seems like it works better but i think i'm missing smtn
w := NDSolve[{y''[x] + y[x] == 2, y[0] == w1, y'[0] == 0},
y, {x, 0, 30}]
w2 = Table[y[x] /. w, {w1, 0.0, 1.0, 0.5}]
because when i try to make a table, it doesn't work:
Table[Evaluate[y[x] /. w2], {x, 10, 30, 10}]
i get an error:
ReplaceAll::reps: {<<1>>[x]} is neither a list of replacement rules nor a valid dispatch table, and so cannot be used for replacing. >>
ps: is there a better place to ask questions like that? mathematica doesn't have supported forums and only has mathGroup e-mail list. it would be nice if stackoverflow would have more specific mathematica tags like simplify, ndsolve, plot manipulation
There are a lot of ways to do that. One is:
w[w1_] := NDSolve[{y''[x] + y[x] == 2,
y'[0] == 0}, y[0] == w1,
y[x], {x, 0, 30}];
Table[Table[{w1,x,y[x] /. w[w1]}, {w1, 0., 1.0, 0.5}]/. x -> u, {u, 10, 30, 10}]
Output:
{{{0., 10, {3.67814}}, {0.5, 10, {3.25861}}, {1.,10, {2.83907}}},
{{0., 20, {1.18384}}, {0.5, 20, {1.38788}}, {1.,20, {1.59192}}},
{{0., 30, {1.6915}}, {0.5, 30, {1.76862}}, {1.,30, {1.84575}}}}
I see you already chose an answer, but I want to toss this solution for families of linear equations up. Specifically, this is to model a slight variation on Lotka-Volterra.
(*Put everything in a module to scope x and y correctly.*)
Module[{x, y},
(*Build a function to wrap NDSolve, and pass it
the initial conditions and range.*)
soln[iCond_, tRange_, scenario_] :=
NDSolve[{
x'[t] == -scenario[[1]] x[t] + scenario[[2]] x[t]*y[t],
y'[t] == (scenario[[3]] - scenario[[4]]*y[t]) -
scenario[[5]] x[t]*y[t],
x[0] == iCond[[1]],
y[0] == iCond[[2]]
},
{x[t], y[t]},
{t, tRange[[1]], tRange[[2]]}
];
(*Build a plot generator*)
GeneratePlot[{iCond_, tRange_, scen_,
window_}] :=
(*Find a way to catch errors and perturb iCond*)
ParametricPlot[
Evaluate[{x[t], y[t]} /. soln[iCond, tRange, scen]],
{t, tRange[[1]], tRange[[2]]},
PlotRange -> window,
PlotStyle -> Thin, LabelStyle -> Medium
];
(*Call the plot generator with different starting conditions*)
graph[scenario_, tRange_, window_, points_] :=
{plots = {};
istep = (window[[1, 2]] - window[[1, 1]])/(points[[1]]+1);
jstep = (window[[2, 2]] - window[[2, 1]])/(points[[2]]+1);
Do[Do[
AppendTo[plots, {{i, j}, tRange, scenario, window}]
, {j, window[[2, 1]] + jstep, window[[2, 2]] - jstep, jstep}
], {i, window[[1, 1]] + istep, window[[1, 2]] - istep, istep}];
Map[GeneratePlot, plots]
}
]
]
We can then use Animate (or table, but animate is awesome)
tRange = {0, 4};
window = {{0, 8}, {0, 6}};
points = {5, 5}
Animate[Show[graph[{3, 1, 8, 2, 0.5},
{0, t}, window, points]], {t, 0.01, 5},
AnimationRunning -> False]

Resources