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]]
Related
So I'm pretty new to Mathematica, and am trying to learn to solve problems in a functional way. The problem I was solving was to list the ways in which I could sum elements from a list (with repetitions), so the sum is leq to some value. The code below solves this just fine.
i = {7.25, 7.75, 15, 19, 22};
m = 22;
getSum[l_List, n_List] := Total[Thread[{l, n}] /. {x_, y_} -> x y];
t = Prepend[Map[Range[0, Floor[m/#]] &, i], List];
Outer ## %;
Flatten[%, ArrayDepth[%] - 2];
Map[{#, getSum[i, #]} &, %];
DeleteCases[%, {_, x_} /; x > m || x == 0];
TableForm[Flatten /# SortBy[%, Last], 0,
TableHeadings -> {None, Append[i, "Total"]}]
However, the code check a lot of unneccesary cases, which could be a problem if m is higher of the list is longer. My question is simply what would be the most Mathematica-esque way of solving this problem, concerning both efficiency and code elegancy.
One simple though not optimal way is :
sol = Reduce[Dot[i, {a, b, c, d, e}] <= m, {a, b, c, d, e}, Integers];
at first try with a smaller i, say i = {7.25, 7.75} to get a feeling about whether you can use this.
You can improve speed by providing upper limits for the coefficients, like in
sol = Reduce[And ## {Dot[i, {a, b, c, d, e}] <= m,
Sequence ## Thread[{a, b, c, d, e} <= Quotient[m, i]]},
{a, b, c, d, e}, Integers]
How about
recurr[numbers_, boundary_] :=
Reap[memoryRecurr[0, {}, numbers, boundary]][[2, 1]];
memoryRecurr[_, _, {}, _] := Null;
memoryRecurr[sum_, numbers_, restNumbers_, diff_] :=
(
Block[
{presentNumber = First[restNumbers], restRest = Rest[restNumbers]}
,
If[
presentNumber <= diff
,
Block[{
newNumbers = Append[numbers, presentNumber],
newSum = sum + presentNumber
},
Sow[{newNumbers, newSum}];
memoryRecurr[
newSum,
newNumbers,
restRest,
diff - presentNumber
];
]
];
memoryRecurr[sum, numbers, restRest, diff]
];
);
So that
recurr[{1, 2, 3, 4, 5}, 7]
->
{{{1}, 1}, {{1, 2}, 3}, {{1, 2, 3}, 6}, {{1, 2, 4}, 7}, {{1, 3},
4}, {{1, 4}, 5}, {{1, 5}, 6}, {{2}, 2}, {{2, 3}, 5}, {{2, 4},
6}, {{2, 5}, 7}, {{3}, 3}, {{3, 4}, 7}, {{4}, 4}, {{5}, 5}}
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]
This is another simple 'matrix' question in Mathematica. I want to show how I did this, and ask if there is a better answer.
I want to select all 'rows' from matrix based on value in the first column (or any column, I used first column here just as an example).
Say, find all rows where the entry in the first position is <=4 in this example:
list = {{1, 2, 3},
{4, 5, 8},
{7 , 8, 9}}
So, the result should be
{{1,2,3},
{4,5,8}}
Well, the problem is I need to use Position, since the result returned by Position can be used directly by Extract. (but can't be used by Part or [[ ]], so that is why I am just looking at Position[] ).
But I do not know how to tell Position to please restrict the 'search' pattern to only the 'first' column so I can do this in one line.
When I type
pos = Position[list, _?(# <= 4 &)]
it returns position of ALL entries which are <=4.
{{1, 1}, {1, 2}, {1, 3}, {2, 1}}
If I first get the first column, then apply Position on it, it works ofcourse
list = {{1, 2, 3},
{4, 5, 8},
{7 , 8, 9}};
pos = Position[list[[All, 1]], _?(# <= 4 &)]
Extract[list, pos]
--> {{1, 2, 3}, {4, 5, 8}}
Also I tried this:
pos = Position[list, _?(# <= 4 &)];
pos = Select[pos, #[[2]] == 1 &] (*only look at ones in the 'first' column*)
{{1, 1}, {2, 1}}--->
and this gives me the correct positions in the first column. To use that to find all rows, I did
pos = pos[[All, 1]] (* to get list of row positions*)
---> {1, 2}
list[[ pos[[1]] ;; pos[[-1]], All]]
{{1, 2, 3},
{4, 5, 8}}
So, to summarize, putting it all together, this is what I did:
method 1
list = {{1, 2, 3},
{4, 5, 8},
{7 , 8, 9}};
pos = Position[list[[All, 1]], _?(# <= 4 &)]
Extract[list, pos]
--> {{1, 2, 3}, {4, 5, 8}}
method 2
list = {{1, 2, 3},
{4, 5, 8},
{7 , 8, 9}}
pos = Position[list, _?(# <= 4 &)];
pos = Select[pos, #[[2]] == 1 &];
pos = pos[[All, 1]];
list[[ pos[[1]] ;; pos[[-1]], All]]
{{1, 2, 3},
{4, 5, 8}}
The above clearly is not too good.
Is method 1 above the 'correct' functional way to do this?
For reference, this is how I do the above in Matlab:
EDU>> A=[1 2 3;4 5 8;7 8 9]
A =
1 2 3
4 5 8
7 8 9
EDU>> A( A(:,1)<=4 , :)
1 2 3
4 5 8
I am trying to improve my 'functional' handling of working with matrices in Mathematica commands, this is an area I feel I am not good at working with lists. I find working with matrices easier for me.
The question is: Is there is a shorter/more functional way to do this in Mathematica?
thanks
You could use Pick[] as follows:
Pick[list, list[[All, 1]], _?(# <= 4 &)]
How about the following?
In[1]:= list = {{1, 2, 3}, {4, 5, 8}, {7, 8, 9}};
In[2]:= Select[list, First[#] <= 4 &]
Out[2]= {{1, 2, 3}, {4, 5, 8}}
Here's a loose translation of your matlab code:
list[[Flatten[Position[Thread[list[[All, 1]] <= 4], True]]]]
(of course, the Flatten would not be needed if I used Extract instead of Part).
There is a faster method than those already presented, using SparseArray. It is:
list ~Extract~
SparseArray[UnitStep[4 - list[[All, 1]]]]["NonzeroPositions"]
Here are speed comparisons with the other methods. I had to modify WReach's method to handle other position specifications.
f1[list_, x_] := Cases[list, {Sequence ## Table[_, {x - 1}], n_, ___} /; n <= 4]
f2[list_, x_] := Select[list, #[[x]] <= 4 &]
f3[list_, x_] := Pick[list, (#[[x]] <= 4 &) /# list]
f4[list_, x_] := Pick[list, UnitStep[4 - list[[All, x]]], 1]
f5[list_, x_] := Pick[list, Thread[list[[All, x]] <= 4]]
f6[list_, x_] := list ~Extract~
SparseArray[UnitStep[4 - list[[All, x]]]]["NonzeroPositions"]
For a table with few rows and many columns (comparing position 7):
a = RandomInteger[99, {250, 150000}];
timeAvg[#[a, 7]] & /# {f1, f2, f3, f4, f5, f6} // Column
0.02248
0.0262
0.312
0.312
0.2808
0.0009728
For a table with few columns and many rows (comparing position 7):
a = RandomInteger[99, {150000, 12}];
timeAvg[#[a, 7]] & /# {f1, f2, f3, f4, f5, f6} // Column
0.0968
0.1434
0.184
0.0474
0.103
0.002872
If you want the rows that meet the criteria, use Cases:
Cases[list, {n_, __} /; n <= 4]
(* {{1, 2, 3}, {4, 5, 8}} *)
If you want the positions within the list rather than the rows themselves, use Position instead of Cases (restricted to the first level only):
Position[list, {n_, __} /; n <= 4, {1}]
(* {{1}, {2}} *)
If you want to be very clever:
Pick[list, UnitStep[4 - list[[All, 1]]], 1]
This also avoids unpacking, which means it'll be faster and use less memory.
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'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.