Related
I have a n x m matrix of data.
How do I create a function that has a sum that includes elements of each column, such that if I input a value, I would get a 1 x m row (where m > 100)?
More specifically, I am computing a discrete Fourier transform of the data in each column that should work for any input frequency I put in.
Here is my code for a single column:
(* Length of time data *)
n = Length[t]
(* Compute discrete fourier transform at specified frequency f *)
DFT[f_] := (t[[2]] - t[[1]]) Sum[
mat[[i + 1]] * Exp[2 Pi I f mat[[i + 1]]], {i, 0, n - 1}];
I'd like to extend this to m columns so that if I want to compute the DFT for a given column at a specific frequency, I can just extract an element of a 1 x m row.
I've considered a function like Map, but it seems like it'll directly apply my function by inputting the value of each element in the row, which isn't exactly what I want.
I am guessing you meant you just want to map a function on a column?
mat = RandomInteger[{0, 10}, {5, 6}];
map[f_, mat_?(MatrixQ[#] &), c_Integer /; c > 0] := f /# mat[[All, c]]
map[f, mat, 2]
It seems like you just need to get the column. The way that matrices are stored in Mathematica has the first coordinate as the row and the second as the column. All coordinates start at 1, not 0. To get an element at a specific coordinate, you use matrix[[row, column]]. If you want a whole row, matrix[[row]]. If you want a column, matrix[[All, column]]. Accordingly, here is one way you might adjust the DFT function:
DFT[f_, list_] := (t[[2]] - t[[1]]) Sum[
list[[i]] * Exp[2 Pi I f list[[i]]], {i, 1, n}];
yourColumnDFT = DFT[f, matrix[[All, columnNumber]]]
In fact, you can make this even simpler by removing the call to Sum because these operations automatically map over lists by index:
DFT[f_, list_] := (t[[2]] - t[[1]]) Total[list Exp[2 Pi I f list]]
By the way, there is a built-in function for this, Fourier (documentation here), which gives a slightly different DFT than yours but is also useful. I recommend looking for built-in functions for these tasks in the future, because Mathematica has a wide range of functionality like this and will save you a lot of trouble.
I would like to write a Mathematica function that constructs a list of all Fibonacci numbers less than n. Moreover, I would like to do this as elegantly and functionally as possible(so without an explicit loop).
Conceptually I want to take an infinite list of the natural numbers, map Fib[n] onto it, and then take elements from this list while they are less than n. How can I do this in Mathematica?
The first part can be done fairly easily in Mathematica. Below, I provide two functions nextFibonacci, which provides the next Fibonacci number greater than the input number (just like NextPrime) and fibonacciList, which provides a list of all Fibonacci numbers less than the input number.
ClearAll[nextFibonacci, fibonacciList]
nextFibonacci[m_] := Fibonacci[
Block[{n},
NArgMax[{n, 1/Sqrt[5] (GoldenRatio^n - (-1)^n GoldenRatio^-n) <= m, n ∈ Integers}, n]
] + 1
]
nextFibonacci[1] := 2;
fibonacciList[m_] := Fibonacci#
Range[0, Block[{n},
NArgMax[{n, 1/Sqrt[5] (GoldenRatio^n - (-1)^n GoldenRatio^-n) < m, n ∈ Integers}, n]
]
]
Now you can do things like:
nextfibonacci[15]
(* 21 *)
fibonacciList[50]
(* {0, 1, 1, 2, 3, 5, 8, 13, 21, 34} *)
The second part though, is tricky. What you're looking for is a Haskell type lazy evaluation that will only evaluate if and when necessary (as otherwise, you can't hold an infinite list in memory). For example, something like (in Haskell):
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
which then allows you to do things like
take 10 fibs
-- [0,1,1,2,3,5,8,13,21,34]
takeWhile (<100) fibs
-- [0,1,1,2,3,5,8,13,21,34,55,89]
Unfortunately, there is no built-in support for what you want. However, you can extend Mathematica to implement lazy style lists as shown in this answer, which was also implemented as a package. Now that you have all the pieces that you need, I'll let you work on this yourself.
If you grab my Lazy package from GitHub, your solution is as simple as:
Needs["Lazy`"]
LazySource[Fibonacci] ~TakeWhile~ ((# < 1000) &) // List
If you want to slightly more literally implement your original description
Conceptually I want to take an infinite list of the natural numbers, map Fib[n] onto it, and then take elements from this list while they are less than n.
you could do it as follows:
Needs["Lazy`"]
Fibonacci ~Map~ Lazy[Integers] ~TakeWhile~ ((# < 1000) &) // List
To prove that this is completely lazy, try the previous example without the // List on the end. You'll see that it stops with the (rather ugly) form:
LazyList[First[
LazyList[Fibonacci[First[LazyList[1, LazySource[#1 &, 2]]]],
Fibonacci /# Rest[LazyList[1, LazySource[#1 &, 2]]]]],
TakeWhile[
Rest[LazyList[Fibonacci[First[LazyList[1, LazySource[#1 &, 2]]]],
Fibonacci /# Rest[LazyList[1, LazySource[#1 &, 2]]]]], #1 <
1000 &]]
This consists of a LazyList[] expression whose first element is the first value of the expression that you're lazily evaluating and whose second element is instructions for how to continue the expansion.
Improvements
It's a little bit inefficient to continually call Fibonacci[n] all the time, especially as n starts getting large. It's actually possible to construct a lazy generator that will calculate the current value of the Fibonacci sequence as we stream:
Needs["Lazy`"]
LazyFibonacci[a_,b_]:=LazyList[a,LazyFibonacci[b,a+b]]
LazyFibonacci[]:=LazyFibonacci[1,1]
LazyFibonacci[] ~TakeWhile~ ((# < 1000)&) // List
Finally, we could generalize this up to a more abstract generating function that takes an initial value for an accumulator, a List of Rules to compute the accumulator's value for the next step and a List of Rules to compute the result from the current accumulator value.
LazyGenerator[init_, step_, extract_] :=
LazyList[Evaluate[init /. extract],
LazyGenerator[init /. step, step, extract]]
And could use it to generate the Fibonacci sequence as follows:
LazyGenerator[{1, 1}, {a_, b_} :> {b, a + b}, {a_, b_} :> a]
Ok, I hope I understood the question. But please note, I am not pure math major, I am mechanical engineering student. But this sounded interesting. So I looked up the formula and this is what I can come up with now. I have to run, but if there is a bug, please let me know and I will fix it.
This manipulate asks for n and then lists all Fibonacci numbers less than n. There is no loop to find how many Fibonacci numbers there are less than n. It uses Reduce to solve for the number of Fibonacci numbers less than n. I take the floor of the result and also threw away a constant that came up with in the solution a complex multiplier.
And then simply makes a table of all these numbers using Mathematica Fibonacci command. So if you enter n=20 it will list 1,1,2,3,5,8,13 and so on. I could do it for infinity as I ran out of memory (I only have 8 GB ram on my pc).
I put the limit for n to 500000 Feel free to edit the code and change it.
Manipulate[
Module[{k, m},
k = Floor#N[Assuming[Element[m, Integers] && m > 0,
Reduce[f[m] == n, m]][[2, 1, 2]] /. Complex[0, 2] -> 0];
TableForm#Join[{{"#", "Fibonacci number" }},
Table[{i, Fibonacci[i]}, {i, 1, k}]]
],
{{n, 3, "n="}, 2, 500000, 1, Appearance -> "Labeled", ImageSize -> Small},
SynchronousUpdating -> False,
ContentSize -> {200, 500}, Initialization :>
{
\[CurlyPhi][n_] := ((1 + Sqrt[5])/2)^n;
\[Psi][n_] := -(1/\[CurlyPhi][n]);
f[n_] := (\[CurlyPhi][n] - \[Psi][n])/Sqrt[5];
}]
Screen shot
The index k of the Fibonacci number Fk is k=Floor[Log[GoldenRatio,Fk]*Sqrt[5]+1/2]],
https://en.wikipedia.org/wiki/Fibonacci_number. Hence, the list of Fibonacci numbers less than or equal to n is
FibList[n_Integer]:=Fibonacci[Range[Floor[Log[GoldenRatio,Sqrt[5]*n+1/2]]]]
Given a set of numbers and a set of binary operations,
what is the fastest way to create random expression trees or exhaustively check every possible combination in Mathematica?
What I am trying to solve is given:
numbers={25,50,75,100,3,6} (* each can ONLY be used ONCE *)
operators={Plus,Subtract,Times,Divide} (* each can be used repeatedly *)
target=99
find expression trees that would evaluate to target.
I have two solutions whose performances I give for the case where expression trees contain exactly 4 of the numbers and 3 operators:
random sample & choice: ~25K trees / second
exhaustive scan: 806400 trees in ~2.15 seconds
(timed on a laptop with: Intel(R) Core(TM)2 Duo CPU T9300 # 2.50GHz, 3GB ram, no parallelization used yet but would be most welcome in answers)
My notebooks are a bit messy at the moment. So I would first love to pose the question and hope for original ideas and answers while I clean up my code for sharing.
Largest possible case is where every expression tree uses up all the (6) numbers and 'Length[numbers]-1' (5) operators.
Performance of methods in the largest case is:
random sample & choice: ~21K trees / second
exhaustive scan: 23224320 trees in ~100 seconds
Also I am using Mathematica 8.0.1 so I am more than all ears if there are any ways to do it in OpenCL or using compiled functions wiht CompilationTarget->"C", etc.
OK, this is not elegant or fast, and it's buggy, but it works (sometimes). It uses a monte carlo method, implementing the metropolis algorithm for a weight function that I (arbitrarily) selected just to see if this would work. This was some time ago for a similar problem; I suppose my mathematica skills have improved as it looks ugly now, but I have no time to fix it at the moment.
Execute this (it looks more reasonable when you paste it into a notebook):
ClearAll[swap];
swap[lst_, {p1_, p2_}] :=
ReplacePart[
lst, {p1 \[Rule] lst\[LeftDoubleBracket]p2\[RightDoubleBracket],
p2 \[Rule] lst\[LeftDoubleBracket]p1\[RightDoubleBracket]}]
ClearAll[evalops];
(*first element of opslst is Identity*)
evalops[opslst_, ord_, nums_] :=
Module[{curval}, curval = First#nums;
Do[curval =
opslst\[LeftDoubleBracket]p\[RightDoubleBracket][curval,
nums\[LeftDoubleBracket]ord\[LeftDoubleBracket]p\
\[RightDoubleBracket]\[RightDoubleBracket]], {p, 2, Length#nums}];
curval]
ClearAll[randomizeOrder];
randomizeOrder[ordlst_] :=
swap[ordlst, RandomInteger[{1, Length#ordlst}, 2]]
ClearAll[randomizeOps];
(*never touch the first element*)
randomizeOps[oplst_, allowedOps_] :=
ReplacePart[
oplst, {RandomInteger[{2, Length#oplst}] \[Rule] RandomChoice[ops]}]
ClearAll[takeMCstep];
takeMCstep[goal_, opslst_, ord_, nums_, allowedops_] :=
Module[{curres, newres, newops, neword, p},
curres = evalops[opslst, ord, nums];
newops = randomizeOps[opslst, allowedops];
neword = randomizeOrder[ord];
newres = evalops[newops, neword, nums];
Switch[Abs[newres - goal],
0, {newops,
neword}, _, (p = Abs[curres - goal]/Abs[newres - goal];
If[RandomReal[] < p, {newops, neword}, {opslst, ord}])]]
then to solve your actual problem, do
ops = {Times, Plus, Subtract, Divide}
nums = {25, 50, 75, 100, 3, 6}
ord = Range[Length#nums]
(*the first element is identity to simplify the logic later*)
oplist = {Identity}~Join~RandomChoice[ops, Length#nums - 1]
out = NestList[
takeMCstep[
99, #\[LeftDoubleBracket]1\[RightDoubleBracket], #\
\[LeftDoubleBracket]2\[RightDoubleBracket], nums, ops] &, {oplist,
ord}, 10000]
and then to see that it worked,
ev = Map[evalops[#\[LeftDoubleBracket]1\[RightDoubleBracket], #\
\[LeftDoubleBracket]2\[RightDoubleBracket], nums] &, out];
ev // Last // N
ev // ListPlot[#, PlotMarkers \[Rule] None] &
giving
thus, it obtained the correct order of operators and numbers after around 2000 tries.
As I said, it's ugly, inefficient, and badly programmed as it was a quick-and-dirty adaptation of a quick-and-dirty hack. If you're interested I can clean up and explain the code.
This was a fun question. Here's my full solution:
ExprEval[nums_, ops_] := Fold[
#2[[1]][#1, #2[[2]]] &,
First#nums,
Transpose[{ops, Rest#nums}]]
SymbolicEval[nums_, ops_] := ExprEval[nums, ToString /# ops]
GetExpression[nums_, ops_, target_] := Select[
Tuples[ops, Length#nums - 1],
(target == ExprEval[nums, #]) &]
Usage example:
nums = {-1, 1, 2, 3};
ops = {Plus, Subtract, Times, Divide};
solutions = GetExpression[nums, ops, 3]
ExprEval[nums, #] & /# solutions
SymbolicEval[nums, #] & /# solutions
Outputs:
{{Plus, Times, Plus}, {Plus, Divide, Plus}, {Subtract, Plus,
Plus}, {Times, Plus, Times}, {Divide, Plus, Times}}
{3, 3, 3, 3, 3}
{"Plus"["Times"["Plus"[-1, 1], 2], 3],
"Plus"["Divide"["Plus"[-1, 1], 2], 3],
"Plus"["Plus"["Subtract"[-1, 1], 2], 3],
"Times"["Plus"["Times"[-1, 1], 2], 3],
"Times"["Plus"["Divide"[-1, 1], 2], 3]}
How it works
The ExprEval function takes in the numbers and operations, and applies them using (I think) RPN:
ExprEval[{1, 2, 3}, {Plus, Times}] == (1 + 2) * 3
It does this by continually folding pairs of numbers using the appropriate operation.
Now that I have a way to evaluate an expression tree, I just needed to generate them. Using Tuples, I'm able to generate all the different operators that I would intersperse between the numbers.
Once you get all possible operations, I used Select to pick out the the ones that evaluate to the target number.
Drawbacks
The solution above is really slow. Generating all the possible tuples is exponential in time. If there are k operations and n numbers, it's on the order of O(k^n).
For n = 10, it took 6 seconds to complete on Win 7 x64, Core i7 860, 12 GB RAM. The timings of the runs match the theoretical time complexity almost exactly:
Red line is the theoretical, blue is experimental. The x-axis is size of the nums input and the y-axis is the time in seconds to enumerate all solutions.
The above solution also solves the problem using a functional programming style. It looks pretty, but the thing also sucks up a butt ton of memory since it's storing the full results at nearly every step.
It doesn't even make use of parallelization, and I'm not entirely certain how you would even parallelize the solution I produced.
Some limitations
Mr. Wizard brought to my attention that this code only solves for only particular set of solutions. Given some input such as {a, b, c, d, e, ... } it only permutes the operators in between the numbers. It doesn't permute the ordering of the numbers. If it were to permute the numbers as well, the time complexity would rise up to O(k^n * n!) where k is the number of operators and n is the length of the input number array.
The following will produce the set of solutions for any permutation of the input numbers and operators:
(* generates a lists of the form
{
{number permutation, {{op order 1}, {op order 2}, ... }
}, ...
}*)
GetAllExpressions[nums_, ops_, target_] :=
ParallelMap[{#, GetExpression[#, ops, target]} &,
Tuples[nums, Length#nums]]
I have N eigenvalues in column vector form.
Thus there are N eigenvectors corresponding to these eigenvalues, forming an eigenvector matrix.
Now, the problem I am working on requires me to sort the eigenvalues column vector in descending order. How do I sort the eigenvectors matrix in the same order as their eigenvalues in order to preserve correspondence?
For example,
m = RandomReal[{0, 1}, {5, 5}];
{evals, evecs} = Eigensystem[m];
SortBy[Transpose[{evals, evecs}], First]
or if you want them in the same form, replace the last line by
Transpose#SortBy[Transpose[{evals, evecs}], First]
EDIT: while I used {evals,evecs}=Eigensystem[m], that's not necessary. I could just have used s=Eigensystem[m] and then used s wherever I currently have {evals,evecs}.
While #acl and #yoda's ways of sorting (i.e. pairing the list elements then sorting together) is easy and commonly used, I'd like to show another generic method to easily sort an arbitrary number of lists based on one particular list (list1):
oo = Ordering[list1]; (* this finds the sorting order of list1 *)
list1[[oo]]
list2[[oo]]
list3[[oo]] (* these order some other lists in the same way *)
You can use the Sort function to sort the eigensystem according to the eigenvalues.
mat = (#*Transpose##) &#RandomReal[NormalDistribution[], {4, 4}];
eigsys = Sort#Transpose#Eigensystem[mat];
Sort's default behavior is to sort by the first column.
Using Mathematica:
matrix = RandomReal[{0, 1}, {4, 4}];
{evals, evecs} = Chop[Transpose[Sort[Transpose[Eigensystem[matrix]]]]];
OutPut:
evals
{-0.296769, 0.187003, 0.52714, 2.00376}
evecs
{{-0.412673,0.844056,-0.0718614,-0.334823},
{-0.370973, -0.472126, 0.76248, 0.241042},
{-0.253163, 0.1719, -0.786782, 0.536034},
{0.557741, 0.381364, 0.65039, 0.347102}}
I was wondering how I could obtain the first element of a (already ordered) list that is greater than a given threshold.
I don't know really well the list manipulation function in Mathematica, maybe someone can give me a trick to do that efficiently.
Select does what you need, and will be consistent, respecting the pre-existing order of the list:
Select[list, # > threshold &, 1]
For example:
In[1]:= Select[{3, 5, 4, 1}, # > 3 &, 1]
Out[1]= {5}
You can provide whatever threshold or criterion function you need in the second argument.
The third argument specifies you only one (i.e., the first) element that matches.
Hope that helps!
Joe correctly states in his answer that one would expect a binary search technique to be faster than Select, which seem to just do a linear search even if the list is sorted:
ClearAll[selectTiming]
selectTiming[length_, iterations_] := Module[
{lst},
lst = Sort[RandomInteger[{0, 100}, length]];
(Do[Select[lst, # == 2 &, 1], {i, 1, iterations}] // Timing //
First)/iterations
]
(I arbitrarily put the threshold at 2 for demonstration purposes).
However, the BinarySearch function in Combinatorica is a) not appropriate (it returns an element which does match the requested one, but not the first (leftmost), which is what the question is asking.
To obtain the leftmost element that is larger than a threshold, given an ordered list, we may proceed either recursively:
binSearch[lst_,threshold_]:= binSearchRec[lst,threshold,1,Length#lst]
(*
return position of leftmost element greater than threshold
breaks if the first element is greater than threshold
lst must be sorted
*)
binSearchRec[lst_,threshold_,min_,max_] :=
Module[{i=Floor[(min+max)/2],element},
element=lst[[i]];
Which[
min==max,max,
element <= threshold,binSearchRec[lst,threshold,i+1,max],
(element > threshold) && ( lst[[i-1]] <= threshold ), i,
True, binSearchRec[lst,threshold,min,i-1]
]
]
or iteratively:
binSearchIterative[lst_,threshold_]:=Module[
{min=1,max=Length#lst,i,element},
While[
min<=max,
i=Floor[(min+max)/2];
element=lst[[i]];
Which[
min==max, Break[],
element<=threshold, min=i+1,
(element>threshold) && (lst[[i-1]] <= threshold), Break[],
True, max=i-1
]
];
i
]
The recursive approach is clearer but I'll stick to the iterative one.
To test its speed,
ClearAll[binSearchTiming]
binSearchTiming[length_, iterations_] := Module[
{lst},
lst = Sort[RandomInteger[{0, 100}, length]];
(Do[binSearchIterative[lst, 2], {i, 1, iterations}] // Timing //
First)/iterations
]
which produces
so, much faster and with better scaling behaviour.
Actually it's not necessary to compile it but I did anyway.
In conclusion, then, don't use Select for long lists.
This concludes my answer. There follow some comments on doing a binary search by hand or via the Combinatorica package.
I compared the speed of a (compiled) short routine to do binary search vs the BinarySearch from Combinatorica. Note that this does not do what the question asks (and neither does BinarySearch from Combinatorica); the code I gave above does.
The binary search may be implemented iteratively as
binarySearch = Compile[{{arg, _Integer}, {list, _Integer, 1}},
Module[ {min = 1, max = Length#list,
i, x},
While[
min <= max,
i = Floor[(min + max)/2];
x = list[[i]];
Which[
x == arg, min = max = i; Break[],
x < arg, min = i + 1,
True, max = i - 1
]
];
If[ 0 == max,
0,
max
]
],
CompilationTarget -> "C",
RuntimeOptions -> "Speed"
];
and we can now compare this and BinarySearch from Combinatorica. Note that a) the list must be sorted b) this will not return the first matching element, but a matching element.
lst = Sort[RandomInteger[{0, 100}, 1000000]];
Let us compare the two binary search routines. Repeating 50000 times:
Needs["Combinatorica`"]
Do[binarySearch[2, lst], {i, 50000}] // Timing
Do[BinarySearch[lst, 2], {i, 50000}] // Timing
(*
{0.073437, Null}
{4.8354, Null}
*)
So the handwritten one is faster. Now since in fact a binary search just visits 6-7 points in the list for these parameters (something like {500000, 250000, 125000, 62500, 31250, 15625, 23437} for instance), clearly the difference is simply overhead; perhaps BinarySearch is more general, for instance, or not compiled.
You might want to look at TakeWhile[] and LengthWhile[] as well.
http://reference.wolfram.com/mathematica/ref/TakeWhile.html
http://reference.wolfram.com/mathematica/ref/LengthWhile.html
list /. {___, y_ /; y > 3, ___} :> {y}
For example
{3, 5, 4, 1} /. {___, y_ /; y > 3, ___} :> {y}
{5}
Using Select will solve the problem, but it is a poor solution if you care about efficiency. Select goes over all the elements of the list, and therefore will take time which is linear in the length of the list.
Since you say the list is ordered, it is much better to use BinarySearch, which will work in a time which is logarithmic in the size of the list. The expression (edit: I have made a small adjustment since the previous expression I wrote did not handle correctly recurring elements in the list. another edit: this still doesn't work when the threshold itself appears in the list as a recurring element, see comments):
Floor[BinarySearch[list,threshold]+1]
will give you the index of the desired element. If all the elements are smaller than the threshold, you'll get the length of the list plus one.
p.s. don't forget to call Needs["Combinatorica'"] before using BinarySearch.
Just for future reference, starting from v10 you can use SelectFirst
It has some added niceties, such as returning Missing[] or default values.
From the docs:
SelectFirst[{e1,e2,…}, crit] gives the first ei for which crit[ei] is True, or Missing["NotFound"] if none is found.
SelectFirst[{e1,e2,…}, crit, default] gives default if there is no ei such that crit[ei] is True.
For your specific case, you would use:
SelectFirst[list, # > threshold &]