Getting a number of arrays from an array list - wolfram-mathematica

Hi I am using Mathematica 5.2. Suppose I have an array list like
In[2]:=lst=Tuples[{0,1},4]
Out[2]={{0,0,0,0},{0,0,0,1},{0,0,1,0},{0,0,1,1},
{0,1,0,0},{0,1,0,1},{0,1,1,0},{0,1,1,1},
{1,0,0,0},{1,0,0,1},{1,0,1,0},{1,0,1,1},
{1,1,0,0},{1,1,0,1},{1,1,1,0},{1,1,1,1}}
Now I want to get 16 arrays from the above array like st1={0,0,0,0}; st2={0,0,0,1}, st3={0,0,1,0}...
How can I get these array lists using a loop. Because if the no. of elements of the above array named lst become larger then it will not be a wise decision to take each of the element of the array lst separately and give their name separately. I tried this like the following way but it is not working...
Do[st[i]=lst[[i]],{i,1,16}]
Plz some body help me in this problem...

It does work, but what you create are the so-called indexed variables. You should access them also using the index, for example:
In[4]:= {st[1], st[2], st[3]}
Out[4]= {{0, 0, 0}, {0, 0, 1}, {0, 1, 0}}

I think what you are trying to do could be done by:
lst = Tuples[{0, 1}, 4];
Table[Evaluate[Symbol["lst" <> ToString[i]]] = lst[[i]], {i, Length#lst}]
So that
lst1 == {0,0,0,0}
But this is not a useful way to manage vars in Mathematica.
Edit
I'll try to show you why having vars lst1,lst2 .. is not useful, and is against the "Mathematica way".
Mathematica works better by applying functions to objects. For example, suppose you want to work with EuclideanDistance. You have a point {1,2,3,4} in R4, and you want to calculate the nearest point from your set to this point.
This is easily done by
eds = EuclideanDistance[{1, 2, 3, 4}, #] & /# Tuples[{0, 1}, 4]
And the nearest point distance is simply:
min = Min[eds]
If you want to know which point/s are the nearest ones, you can do:
Select[lst, EuclideanDistance[{1, 2, 3, 4}, #] == min &]
Now, try to do that same things with your intended lst1,lst2 .. asignments, and you will find it, although not impossible, very,very convoluted.
Edit
BTW, once you have
lst = Tuples[{0, 1}, 4];
You can access each element of the list just by typing
lst[[1]]
etc. In case you need to loop. But again, loops are NOT the Mathematica way. For example, if you want to get another list, with your elements normalized, don't loop and just do:
lstNorm = Norm /# lst
Which is cleaner and quicker than
Do[st[i] = Norm#lst[[i]], {i, 1, 16}]
You will find that defining downvalues (like st[i]) above) is useful when solving equations, but besides that many operations that in other languages are done using arrays, in Mathematica are better carried out by using lists.
Edit
Answering your comment actually I need each element of array lst to find the value of function such as f[x,y,z,k]=x-y+z+k. Such function may be
(#1 - #2 + #3 + #4) & ### lst
or
(#[[1]] - #[[2]] + #[[3]] + #[[4]]) & /# lst
Out:
{0, 1, 1, 2, -1, 0, 0, 1, 1, 2, 2, 3, 0, 1, 1, 2}
HTH!

You can do this:
Table[
Evaluate[
Symbol["st" <> ToString#i]] = lst[[i]],
{i, 1, Length#lst}];
at the end of which try Names["st*"] to see that you now have st1 to st16 defined. You could also do this with MapIndexed, like so:
MapIndexed[(Evaluate#Symbol["sts" <> ToString~Apply~#2] = #1) &, lst]
after which Names["sts*"] shows again that it has worked. Both of these can be done using a loop if this is what you (but I do not see what it buys you).
On the other hand, this way, when you want to access one of them, you need to do something like Symbol["sts" <> ToString[4]]. Using what you have already done or something equivalent, eg,
Table[
Evaluate[stg[i]] = lst[[i]],{i, 1, Length#lst}]
you end up with stg[1], stg[2] etc, and you can access them much more easily by eg Table[stg[i],{i,1,Length#lst}]
You can see what has been defined by ?stg or in more detail by DownValues[stg].
Or is it something else you want?
Leonid linked to a tutorial, which I suggest you read, by the way.

There are N ways of doing this, though like belisarius I have my doubts about your approach. Nonetheless, the easiest way I've found to manage things like this is to use what Mathematica calls "pure functions", like so:
In[1]:= lst = Tuples[{0,1}, 4];
In[2]:= With[{setter = (st[#1] = #2) &},
Do[setter[i, lst[[i]]], {i, Length#lst}]];
Doing it this way, the evaluation rules for special do just what you want. However, I'd approach this without a loop at all, just using a single definition:
In[3]:= ClearAll[st] (* Clearing the existing definitions is important! *)
In[4]:= st[i_Integer] := lst[[i]]
I think if you provide more detail about what you're trying to accomplish, we'll be able to provide more useful advice.
EDIT: Leonid Shifrin comments that if you change the definition of lst after the fact, the change will also affect st. You can avoid this by using With in the way he describes:
With[{rhs = lst},
st[i_Integer] := rhs[[i]]];
I don't know which will be more useful given what you're trying to do, but it's an important point either way.

Maybe something like this?
MapThread[Set, {Array[st, Length#lst], lst}];
For example:
{st[1], st[10], st[16]}
Out[14]= {{0, 0, 0, 0}, {1, 0, 0, 1}, {1, 1, 1, 1}}

Related

manipulating one element in a list in mathematica

I have a list of 200 data points. I want to select one value, and change the data using the manipulate function to create a bad data point, and observe the effects on the graph.
My recent attempts included creating a variable i, and assigning like:
myarray[[80,2]] = i;
and then use manipulate as such:
Manipulate[Curve[myarray], {i, 0, 5}]
This is not giving the desired output, however. It doesn't really make sense to me to put it like that, but I don't see the alternative way. Any help on this particular problem would be greatly appreciated!
Making up some data and a Curve function :-
myarray = Transpose[{Range[10], Range[10]/2}];
Curve[myarray_] := ListLinePlot[myarray]
Manipulate[myarray[[8, 2]] = i; Curve[myarray], {i, 0, 5}]
To complement Chris Degnen's answer, which shows a good approach, here is an explanation for why your original code failed.
Manipulate, like Module, acts as a scoping construct. For this reason the i used by Manipulate (the manipulation variable) is not the same i as set with myarray[[80, 2]] = i; -- it exists in a different Context:
Manipulate[Context[i], {i, 0, 5}]
(* FE` *)
Here is a minimal example of the problem:
ClearAll[x, i]
x = i;
Manipulate[{x, i}, {i, 0, 5}]
(* {i, 2.24} *)
One way around this is to use Block, but you need to use a different name for the manipulate variable:
ClearAll[x, i]
x = {1, 2, i};
Manipulate[Block[{i = ii}, x], {ii, 0, 5}]
(* {1, 2, 1.41} *)

Wolfram Matematica: set NIntegral's domain with Table

I would like perform an NIntegrate in Wolfram Mathematica in n-dimension, for example making the NIntegrate of the 9-dimension function:
p=Product[(1+x[i])^((-1)^i),{i,0,9}]
so I thought to set the range with a Table:
t=Table[ {x[i], 1,2}, {i,0,9}]
Unfortunately the command
NIntegrate[p,t]
returns the Error:
NIntegrate::vars:
Integration range specification t is not of the form {x, xmin, ..., xmax}.
I've tested with some commands as "Extract", "Part" and so on, but nothing works.
Someone can help a niubb as me?!
Thanks for reading!
You were almost there. Some further manipulation of the integration limits is needed:
p = Product[(1 + x[i])^((-1)^i), {i, 0, 9}]
t = Table[{x[i], 1, 2}, {i, 0, 9}]
Integrate[p, Evaluate[Sequence ## t]]
(*
3125/32 Log[3/2]^5
*)

Replace a part in a table n times by adding the previus values of each iteration and substructing the initial value

I have the following Nested table
(myinputmatrix = Table[Nest[function, myinputmatrix[[i]][[j]],
myinputmatrix[[i]][[j]][[2]][[2]] +
myinputmatrix[[i]][[j]][[3]][[2]]], {i,
Dimensions[myinputmatrix][[1]]}, {j,
Dimensions[myinputmatrix][[2]]}]) // TableForm
fq[k_?NumericQ] := Count[RandomReal[{0, 1}, k], x_ /; x < .1]
function[x_List] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #1,
{2, 2} -> x[[2]][[2]] + #1,
{3, 1} -> x[[3]][[1]] - #2, {3, 2} ->
x[[3]][[2]] + #2}] &[fq[x[[2]][[1]]], fq[x[[2]][[1]]]];
My problem is that I want to add only the #1 in the bold part above, but not only the new one, I want it to add all #1 for the n times (Nest function times]
If I try the function
function[x_List] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #1, {2, 2} -> #1,
{3, 1} -> x[[3]][[1]] - #2, {3, 2} -> #2}] &[fq[x[[2]][[1]]],
fq[x[[2]][[1]]]];
I am having as a result the last value of fq[k]. I thought of replacing that part in my table with 0 but is not going to work since I am using it in my nested list, also I thought of substricting that part from my initial table but I am not sure which way is the best to do it and if the way I am thinking is the correct one. Can anyone help me?
If I may restate the problem and hopefully clarify the question for myself. At each iteration in the Nest, you want to add not the current (random) output from fq, but the cumulation of the current and all past values of it. But because the random output depends at each iteration on the input matrix, you need to calculate both the random number and the current value of the matrix in the same iteration.
If that hadn't been true you could use Fold.
Restating fq as Sasha suggested EDIT with some type checking to avoid problems with incorrect input:
fq[k_Integer?Positive]:=RandomVariate[BinomialDistribution[k,.1]]
You might want to add some other error checking code. Something like this, depending on your requirements, might do.
fq[0]:= 0;
fq[k_Real?Positive]:=RandomVariate[BinomialDistribution[Round[k],.1]]
You need function to take the random numbers as parameters. EDIT 1 and 2 I have changed the syntax of this function to use the parameters explicitly instead of the original question's anonymous function within a function. This should avoid some syntax errors. Also note that I have used "NumericQ" rather than "Real" as the type for the rv1 and rv2 parameters, because they can be integers at the start of the Nest iteration.
function[x_List, rv1_?NumericQ, rv2_?NumericQ] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - rv1, {2, 2} -> rv1,
{3, 1} -> x[[3]][[1]] - rv2, {3, 2} -> rv2}]
And then pass the current random number as a local constant using With to a Nest function that works on a list containing your matrix and the cumulation of the random variates. I have used myoutputmatrix because I really don't like the idea of rewriting existing expressions all the time. That's just me. Now, the one other thing is that you need to set n, the number of iterates. I've set it to 5 but you can make this a parameter in a function if you want (see below).
(myoutputmatrix = Table[ First[Nest[With[{rv=fq[#1[[1]][[2]][[1]] ]},
{function[#1[[1]],rv, rv+#1[[2]] ],rv+#1[[2]] }]&,
{ myinputmatrix[[i]][[j]], 0 }, 5]],
{i, Dimensions[myinputmatrix][[1]]}, {j,
Dimensions[myinputmatrix][[2]]}]) // TableForm
The First is there because in the end you only want the matrix, not the cumulation of the random variates.
outputmatrix[input_List, n_Integer?Positive] /;
Length[Dimensions[input]] == 4 :=
Table[First[
Nest[With[{rv = fq[#1[[1]][[2]][[1]]]}, {function[#1[[1]], rv,
rv + #1[[2]]], rv + #1[[2]]}] &, {input[[i]][[j]], 0}, n]],
{i, Dimensions[input][[1]]}, {j, Dimensions[input][[2]]}]
outputmatrix[myinputmatrix, 10] // TableForm
EDIT I have checked this now and it runs, but note that you can get negative numbers in the output, which is not what you want, I don't think.

Generate a list in Mathematica with a conditional tested for each element

Suppose we want to generate a list of primes p for which p + 2 is also prime.
A quick solution is to generate a complete list of the first n primes and use the Select function to return the elements which meet the condition.
Select[Table[Prime[k], {k, n}], PrimeQ[# + 2] &]
However, this is inefficient as it loads a large list into the memory before returning the filtered list. A For loop with Sow/Reap (or l = {}; AppendTo[l, k]) solves the memory issue, but it is far from elegant and is cumbersome to implement a number of times in a Mathematica script.
Reap[
For[k = 1, k <= n, k++,
p = Prime[k];
If[PrimeQ[p + 2], Sow[p]]
]
][[-1, 1]]
An ideal solution would be a built-in function which allows an option similar to this.
Table[Prime[k], {k, n}, AddIf -> PrimeQ[# + 2] &]
I will interpret this more as a question about automation and software engineering rather than about the specific problem at hand, and given a large number of solutions posted already. Reap and Sow are good means (possibly, the best in the symbolic setting) to collect intermediate results. Let us just make it general, to avoid code duplication.
What we need is to write a higher-order function. I will not do anything radically new, but will simply package your solution to make it more generally applicable:
Clear[tableGen];
tableGen[f_, iter : {i_Symbol, __}, addif : Except[_List] : (True &)] :=
Module[{sowTag},
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[#,sowTag]] &[f[i]], iter],sowTag]];
The advantages of using Do over For are that the loop variable is localized dynamically (so, no global modifications for it outside the scope of Do), and also the iterator syntax of Do is closer to that of Table (Do is also slightly faster).
Now, here is the usage
In[56]:= tableGen[Prime, {i, 10}, PrimeQ[# + 2] &]
Out[56]= {3, 5, 11, 17, 29}
In[57]:= tableGen[Prime, {i, 3, 10}, PrimeQ[# + 1] &]
Out[57]= {}
In[58]:= tableGen[Prime, {i, 10}]
Out[58]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}
EDIT
This version is closer to the syntax you mentioned (it takes an expression rather than a function):
ClearAll[tableGenAlt];
SetAttributes[tableGenAlt, HoldAll];
tableGenAlt[expr_, iter_List, addif : Except[_List] : (True &)] :=
Module[{sowTag},
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[#,sowTag]] &[expr], iter],sowTag]];
It has an added advantage that you may even have iterator symbols defined globally, since they are passed unevaluated and dynamically localized. Examples of use:
In[65]:= tableGenAlt[Prime[i], {i, 10}, PrimeQ[# + 2] &]
Out[65]= {3, 5, 11, 17, 29}
In[68]:= tableGenAlt[Prime[i], {i, 10}]
Out[68]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}
Note that since the syntax is different now, we had to use the Hold-attribute to prevent the passed expression expr from premature evaluation.
EDIT 2
Per #Simon's request, here is the generalization for many dimensions:
ClearAll[tableGenAltMD];
SetAttributes[tableGenAltMD, HoldAll];
tableGenAltMD[expr_, iter__List, addif : Except[_List] : (True &)] :=
Module[{indices, indexedRes, sowTag},
SetDelayed ## Prepend[Thread[Map[Take[#, 1] &, List ## Hold ### Hold[iter]],
Hold], indices];
indexedRes =
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[{#, indices},sowTag]] &[expr], iter],sowTag];
Map[
First,
SplitBy[indexedRes ,
Table[With[{i = i}, Function[Slot[1][[2, i]]]], {i,Length[Hold[iter]] - 1}]],
{-3}]];
It is considerably less trivial, since I had to Sow the indices together with the added values, and then split the resulting flat list according to the indices. Here is an example of use:
{i, j, k} = {1, 2, 3};
tableGenAltMD[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}, # < 7 &]
{{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}
I assigned the values to i,j,k iterator variables to illustrate that this function does localize the iterator variables and is insensitive to possible global values for them. To check the result, we may use Table and then delete the elements not satisfying the condition:
In[126]:=
DeleteCases[Table[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}],
x_Integer /; x >= 7, Infinity] //. {} :> Sequence[]
Out[126]= {{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}
Note that I did not do extensive checks so the current version may contain bugs and needs some more testing.
EDIT 3 - BUG FIX
Note the important bug-fix: in all functions, I now use Sow with a custom unique tag, and Reap as well. Without this change, the functions would not work properly when expression they evaluate also uses Sow. This is a general situation with Reap-Sow, and resembles that for exceptions (Throw-Catch).
EDIT 4 - SyntaxInformation
Since this is such a potentially useful function, it is nice to make it behave more like a built-in function. First we add syntax highlighting and basic argument checking through
SyntaxInformation[tableGenAltMD] = {"ArgumentsPattern" -> {_, {_, _, _., _.}.., _.},
"LocalVariables" -> {"Table", {2, -2}}};
Then, adding a usage message allows the menu item "Make Template" (Shift+Ctrl+k) to work:
tableGenAltMD::usage = "tableGenAltMD[expr,{i,imax},addif] will generate \
a list of values expr when i runs from 1 to imax, \
only including elements if addif[expr] returns true.
The default of addiff is True&."
A more complete and formatted usage message can be found in this gist.
I think the Reap/Sow approach is likely to be most efficient in terms of memory usage. Some alternatives might be:
DeleteCases[(With[{p=Prime[#]},If[PrimeQ[p+2],p,{}] ] ) & /# Range[K]),_List]
Or (this one might need some sort of DeleteCases to eliminate Null results):
FoldList[[(With[{p=Prime[#2]},If[PrimeQ[p+2],p] ] )& ,1.,Range[2,K] ]
Both hold a big list of integers 1 to K in memory, but the Primes are scoped inside the With[] construct.
Yes, this is another answer. Another alternative that includes the flavour of the Reap/Sow approach and the FoldList approach would be to use Scan.
result = {1};
Scan[With[{p=Prime[#]},If[PrimeQ[p+2],result={result,p}]]&,Range[2,K] ];
Flatten[result]
Again, this involves a long list of integers, but the intermediate Prime results are not stored because they are in the local scope of With. Because p is a constant in the scope of the With function, you can use With rather than Module, and gain a bit of speed.
You can perhaps try something like this:
Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] := Union#Flatten#(f /# Range[k]);
If you want both the prime p and the prime p+2, then the solution is
Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] :=
Module[{primes = f /# Range[k]},
Union#Flatten#{primes, primes + 2}];
Well, someone has to allocate memory somewhere for the full table size, since it is not known before hand what the final size will be.
In the good old days before functional programming :), this sort of thing was solved by allocating the maximum array size, and then using a separate index to insert to it so no holes are made. Like this
x=Table[0,{100}]; (*allocate maximum possible*)
j=0;
Table[ If[PrimeQ[k+2], x[[++j]]=k],{k,100}];
x[[1;;j]] (*the result is here *)
{1,3,5,9,11,15,17,21,27,29,35,39,41,45,51,57,59,65,69,71,77,81,87,95,99}
Here's another couple of alternatives using NextPrime:
pairs1[pmax_] := Select[Range[pmax], PrimeQ[#] && NextPrime[#] == 2 + # &]
pairs2[pnum_] := Module[{p}, NestList[(p = NextPrime[#];
While[p + 2 != (p = NextPrime[p])];
p - 2) &, 3, pnum]]
and a modification of your Reap/Sow solution that lets you specify the maximum prime:
pairs3[pmax_] := Module[{k,p},
Reap[For[k = 1, (p = Prime[k]) <= pmax, k++,
If[PrimeQ[p + 2], Sow[p]]]][[-1, 1]]]
The above are in order of increasing speed.
In[4]:= pairs2[10000]//Last//Timing
Out[4]= {3.48,1261079}
In[5]:= pairs1[1261079]//Last//Timing
Out[5]= {6.84,1261079}
In[6]:= pairs3[1261079]//Last//Timing
Out[7]= {0.58,1261079}

"Select any" in Mathematica

Does mathematica have something like "select any" that gets any element of a list that satisfies a criterion?
If you just want to return after the first matching element, use the optional third argument to Select, which is the maximum number of results to return. So you can just do
Any[list_List, crit_, default_:"no match"] :=
With[{maybeMatch = Select[list, crit, 1]},
If[maybeMatch =!= {},
First[maybeMatch],
default]
Mathematica lacks a great way to signal failure to find an answer, since it lacks multiple return values, or the equivalent of Haskell's Maybe type. My solution is to have a user-specifiable default value, so you can make sure you pass in something that's easily distinguishable from a valid answer.
Well, the downside of Eric's answer is that it does execute OddQ on all elements of the list. My call is relatively costly, and it feels wrong to compute it too often. Also, the element of randomness is clearly unneeded, the first one is fine with me.
So, how about
SelectAny[list_List, criterion_] :=
Catch[Scan[ If[criterion[#], Throw[#, "result"]] &, list];
Throw["No such element"], "result"]
And then
SelectAny[{1, 2, 3, 4, 5}, OddQ]
returns 1.
I still wish something were built into Mathematica. Using home-brew functions kind of enlarges your program without bringing much direct benefit.
The Select function provides this built-in, via its third argument which indicates the maximum number of items to select:
In[1]:= Select[{1, 2, 3, 4, 5}, OddQ, 1]
Out[1]= {1}
When none match:
In[2]:= Select[{2, 4}, OddQ, 1]
Out[2]= {}
Edit: Oops, missed that nes1983 already stated this.
You can do it relatively easily with Scan and Return
fstp[p_, l_List] := Scan[ p## && Return## &, l ]
So
In[2]:= OddQ ~fstp~ Range[1,5]
Out[2]= 1
In[3]:= EvenQ ~fstp~ Range[1,5]
Out[3]= 2
I really wish Mathematica could have some options to make expressions evaluated lazily. In a lazy language such as Haskell, you can just define it as normal
fstp p = head . filter p
There's "Select", that gets all the elements that satisfy a condition. So
In[43]:= Select[ {1, 2, 3, 4, 5}, OddQ ]
Out[43]= {1, 3, 5}
Or do you mean that you want to randomly select a single matching element? I don't know of anything built-in, but you can define it pretty quickly:
Any[lst_, q_] :=
Select[ lst, q] // (Part[#, 1 + Random[Integer, Length[#] - 1]]) &
Which you could use the same way::
In[51]:= Any[ {1, 2, 3, 4, 5}, OddQ ]
Out[51]= 3

Resources