Graphics#Flatten[Table[
(*colors, dont mind*)
{ColorData["CMYKColors"][(a[[r, t]] - .000007)/(.0003 - 0.000007)],
(*point size, dont mind*)
PointSize[1/Sqrt[r]/10],
(*Coordinates for your points "a" is your data matrix *)
Point[
{(rr =Log[.025 + (.58 - .25)/64 r]) Cos#(tt = t 5 Degree),
rr Sin#tt}]
} &#
(*values for the iteration*)
, {r, 7, 64}, {t, 1, 72}], 1]
(*Rotation, dont mind*)
/. gg : Graphics[___] :> Rotate[gg, Pi/2]
Okay, I'll bite. First, Mathematica allows functions to be applied via one of several forms: standard form - f[x], prefix form - f # x, postfix form - f // x, and infix form - x ~ f ~ y. Belisarius's code uses both standard and prefix form.
So, let's look at the outermost functions first: Graphics # x /. gg : Graphics[___]:> Rotate[gg,Pi/2], where x is everything inside of Flatten. Essentially, what this does is create a Graphics object from x and using a named pattern (gg : Graphics[___]) rotates the resulting Graphics object by 90 degrees.
Now, to create a Graphics object, we need to supply a bunch of primitives and this is in the form of a nested list, where each sublist describes some element. This is done via the Table command which has the form: Table[ expr, iterators ]. Iterators can have several forms, but here they both have the form {var, min, max}, and since they lack a 4th term, they take on each value between min and max in integer steps. So, our iterators are {r, 7, 64} and {t, 1, 72}, and expr is evaluated for each value that they take on. Since, we have two iterators this produces a matrix, which would confuse Graphics, so we using Flatten[ Table[ ... ], 1] we take every element of the matrix and put it into a simple list.
Each element that Table produces is simply: color (ColorData), point size (PointSize), and point location (Point). So, with Flatten, we have created the following:
Graphics[{{color, point size, point}, {color, point size, point}, ... }]
The color generation is taken from the data, and it assumes that the data has been put into a list called a. The individual elements of a are accessed through the Part construct: [[]]. On the surface, the ColorData construct is a little odd, but it can be read as ColorData["CMYKColors"] returns a ColorDataFunction that produces a CMYK color value when a value between 0 and 1 is supplied. That is why the data from a is scaled the way it is.
The point size is generated from the radial coordinate. You'd expect with 1/Sqrt[r] the point size should be getting smaller as r increases, but the Log inverts the scale.
Similarly, the point location is produced from the radial and angular (t) variables, but Point only accepts them in {x,y} form, so he needed to convert them. Two odd constructs occur in the transformation from {r,t} to {x,y}: both rr and tt are Set (=) while calculating x allowing them to be used when calculating y. Also, the term t 5 Degree lets Mathematica know that the angle is in degrees, not radians. Additionally, as written, there is a bug: immediately following the closing }, the terms & and # should not be there.
Does that help?
Related
I have a problem with the second derivation of an image function I(x,y).
The first derivations are:
I_x(x,y) = I(x+1,y) - I(x,y) and
I_y(x,y) = I(x,y+1) - I(x,y).
But when I try to derive I_x in x-direction again, I get this:
I_xx(x,y) = I(x+2,y) - 2*I(x+1,y) + I(x,y), but the right answer seems to be this: I_xx(x,y) = I(x+1,y) + I(x-1,y) -2*I(x,y). Where is my mistake? Can anybody please explain it?
The answer to your question can be seen in the following example. In the "right" answer the second derivative at x is centered around the point x. In your answer, the second derivative is centered around the point x+1. It is good to have derivatives line up as much as possible in many applications. In some sense you have the right answer just as well as the "right" answer. It is a matter of defining your alignment and being consistent. Given an array (let's use 1 based arrays for the moment)
x(1), x(2), x(3), x(4), x(5), x(6)
x = [3, 2, 1, 8, 9, 4]
The first derivative is
x'(1), x'(2), x'(3), x'(4), x'(5)
f'(x) = [3-2, 2-1, 1-8, 8-9, 9-4]
Notice that the x' has one element less than x. We can get around this if we make assumptions on the boundary conditions, which we will not do at present.
The second derivative is
x'(1)-x'(2), x'(2)-x'(3), x'(3)-x'(4), x'(4)-x'(5)
We only have 4 points that have a valid second derivative. In the way you computed the 2nd derivative you simple take the first second derivative to be x''(1). In this way we get the labeling as follows:
x''(1), x''(2), x''(3), x''(4),
x''=[(3-2)-(2-1), (2-1)-(1-8), (1-8)-(8-9), (8-9)-(9-4)]
In general your second derivative which is what you came up with can be written as:
x''(p) = x(p+2)-2*x(p+1)+x(p)
In your second derivative valid indices take the values 1..4 You do not have defined x''(5) as that would require x(5+2)-2*x(5+1)+x(5) and the original array has only 6 elements so x(7) is undefined.
Another way to label the points with the 2nd derivatives centered and aligned such that the nth second derivative is centered around the nth point in the original array is as follows:
x''(2), x''(3), x''(4), x''(5),
x''=[(3-2)-(2-1), (2-1)-(1-8), (1-8)-(8-9), (8-9)-(9-4)]
In general this can be written as:
x''(p) = x(p+1)-2*x(p)+x(p-1)
Notice that this second derivative valid indices are in the range 2..5 In this case x''(1) is not defined as that would require x(1+1)-2*x(1)+x(1-1) and the original array since we have 1 based arrays does not have a value at x(0).
In both cases the form is the same. It's just you are labeling the points differently.
Odd numbered derivatives we cannot center around points in a finite difference, whereas even numbered derivatives we can center to have more intuitive alignment for downstream calculations.
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 have some periodic data, but the amount of data is not a multiple of
the period. How can I Fourier analyze this data? Example:
% Let's create some data for testing:
data = Table[N[753+919*Sin[x/623-125]], {x,1,25000}]
% I now receive this data, but have no idea that it came from the
formula above. I'm trying to reconstruct the formula just from 'data'.
% Looking at the first few non-constant terms of the Fourier series:
ListPlot[Table[Abs[Fourier[data]][[x]], {x,2,20}], PlotJoined->True,
PlotRange->All]
shows an expected spike at 6 (since the number of periods is really
25000/(623*2*Pi) or about 6.38663, though we don't know this).
% Now, how do I get back 6.38663? One way is to "convolve" the data with
arbitrary multiples of Cos[x].
convolve[n_] := Sum[data[[x]]*Cos[n*x], {x,1,25000}]
% And graph the "convolution" near n=6:
Plot[convolve[n],{n,5,7}, PlotRange->All]
we see a spike roughly where expected.
% We try FindMaximum:
FindMaximum[convolve[n],{n,5,7}]
but the result is useless and inaccurate:
FindMaximum::fmmp:
Machine precision is insufficient to achieve the requested accuracy or
precision.
Out[119]= {98.9285, {n -> 5.17881}}
because the function is very wiggly.
% By refining our interval (using visual analysis on the plots), we
finally find an interval where convolve[] doesn't wiggle too much:
Plot[convolve[n],{n,6.2831,6.2833}, PlotRange->All]
and FindMaximum works:
FindMaximum[convolve[n],{n,6.2831,6.2833}] // FortranForm
List(1.984759605826571e7,List(Rule(n,6.2831853071787975)))
% However, this process is ugly, requires human intervention, and
computing convolve[] is REALLY slow. Is there a better way to do this?
% Looking at the Fourier series of the data, can I somehow divine the
"true" number of periods is 6.38663? Of course, the actual result
would be 6.283185, since my data fits that better (because I'm only
sampling at a finite number of points).
Based on Mathematica help for the Fourier function / Applications / Frequency Identification:
Checked on version 7
n = 25000;
data = Table[N[753 + 919*Sin[x/623 - 125]], {x, 1, n}];
pdata = data - Total[data]/Length[data];
f = Abs[Fourier[pdata]];
pos = Ordering[-f, 1][[1]]; (*the position of the first Maximal value*)
fr = Abs[Fourier[pdata Exp[2 Pi I (pos - 2) N[Range[0, n - 1]]/n],
FourierParameters -> {0, 2/n}]];
frpos = Ordering[-fr, 1][[1]];
N[(pos - 2 + 2 (frpos - 1)/n)]
returns 6.37072
Look for the period length using autocorrelation to get an estimate:
autocorrelate[data_, d_] :=
Plus ## (Drop[data, d]*Drop[data, -d])/(Length[data] - d)
ListPlot[Table[{d, autocorrelate[data, d]}, {d, 0, 5000, 100}]]
A smart search for the first maximum away from d=0 may be the best estimate you can get form the available data?
(* the data *)
data = Table[N[753+919*Sin[x/623-125]], {x,1,25000}];
(* Find the position of the largest Fourier coefficient, after
removing the last half of the list (which is redundant) and the
constant term; the [[1]] is necessary because Ordering returns a list *)
f2 = Ordering[Abs[Take[Fourier[data], {2,Round[Length[data]/2+1]}]],-1][[1]]
(* Result: 6 *)
(* Directly find the least squares difference between all functions of
the form a+b*Sin[c*n-d], with intelligent starting values *)
sol = FindMinimum[Sum[((a+b*Sin[c*n-d]) - data[[n]])^2, {n,1,Length[data]}],
{{a,Mean[data]},{b,(Max[data]-Min[data])/2},{c,2*f2*Pi/Length[data]},d}]
(* Result (using //InputForm):
FindMinimum::sszero:
The step size in the search has become less than the tolerance prescribed by
the PrecisionGoal option, but the gradient is larger than the tolerance
specified by the AccuracyGoal option. There is a possibility that the method
has stalled at a point that is not a local minimum.
{2.1375902350021628*^-19, {a -> 753., b -> -919., c -> 0.0016051364365971107,
d -> 2.477886509998064}}
*)
(* Create a table of values for the resulting function to compare to 'data' *)
tab = Table[a+b*Sin[c*x-d], {x,1,Length[data]}] /. sol[[2]];
(* The maximal difference is effectively 0 *)
Max[Abs[data-tab]] // InputForm
(* Result: 7.73070496506989*^-12 *)
Although the above doesn't necessarily fully answer my question, I found it
somewhat remarkable.
Earlier, I'd tried using FindFit[] with Method -> NMinimize (which is
supposed to give a better global fit), but that didn't work well,
possibly because you can't give FindFit[] intelligent starting values.
The error I get bugs me but appears to be irrelevant.
Is there an elegant way to change the diagonals of a matrix to a new list of values, the
equivalent of Band with SparseArray?
Say I have the following matrix (see below)
(mat = Array[Subscript[a, ##] &, {4, 4}]) // MatrixForm
and I'd like to change the main diagonal to the following to get "new mat" (see below)
newMainDiagList = Flatten#Array[Subscript[new, ##] &, {1, 4}]
I know it is easy to change the main diagonal to a given value using ReplacePart. For example:
ReplacePart[mat, {i_, i_} -> 0]
I'd also like not to be restricted to the main diagonal (in the same way that Band is not so restricted with SparseArray)
(The method I use at the moment is the following!)
(Normal#SparseArray[Band[{1, 1}] -> newMainDiagList] +
ReplacePart[mat, {i_, i_} -> 0]) // MatrixForm
(Desired Output is 'new mat')
Actually, you don't need to use Normal whatsoever. A SparseArray plus a "normal" matrix gives you a "normal" matrix. Using Band is, on initial inspection, the most flexible approach, but an effective (and slightly less flexible) alternative is:
DiagonalMatrix[newDiagList] + ReplacePart[mat, {i_,i_}->0]
DiagonalMatrix also accepts a second integer parameter which allows you to specify which diagonal that newDiagList represents with the main diagonal represented by 0.
The most elegant alternative, however, is to use ReplacePart a little more effectively: the replacement Rule can be a RuleDelayed, e.g.
ReplacePart[mat, {i_,i_} :> newDiagList[[i]] ]
which does your replacement directly without the intermediate steps.
Edit: to mimic Band's behavior, we can also add conditions to the pattern via /;. For instance,
ReplacePart[mat, {i_,j_} /; j==i+1 :> newDiagList[[i]]
replaces the diagonal immediately above the main one (Band[{1,2}]), and
ReplacePart[mat, {i_,i_} /; i>2 :> newDiagList[[i]]
would only replace the last two elements of the main diagonal in a 4x4 matrix (Band[{3,3}]). But, it is much simpler using ReplacePart directly.
I know that using the Insert menu, you can create a matrix with vertical and horizontal lines, but not a more generic partition, such as dividing a 4x4 matrix into 4 2x2 partitions. Nor, can MatrixForm do any sort of partitioning. So, how would I go about programmatically displaying such a partitioned matrix? I would like to retain the ability of MatrixForm to act only as a wrapper and not affect subsequent evaluations, but it is not strictly necessary. I suspect this would involve using a Grid, but I haven't tried it.
After playing around for far too long trying to make Interpretation drop the displayed form and use the matrix when used in subsequent lines, I gave up and just made a wrapper that acts almost exactly like MatrixForm. This was really quick as it was a simple modification of this question.
Clear[pMatrixForm,pMatrixFormHelper]
pMatrixForm[mat_,col_Integer,row_:{}]:=pMatrixForm[mat,{col},row]
pMatrixForm[mat_,col_,row_Integer]:=pMatrixForm[mat,col,{row}]
pMatrixFormHelper[mat_,col_,row_]:=Interpretation[MatrixForm[
{Grid[mat,Dividers->{Thread[col->True],Thread[row->True]}]}],mat]
pMatrixForm[mat_?MatrixQ,col:{___Integer}:{},row:{___Integer}:{}]:=
(CellPrint[ExpressionCell[pMatrixFormHelper[mat,col,row],
"Output",CellLabel->StringJoin["Out[",ToString[$Line],"]//pMatrixForm="]]];
Unprotect[Out];Out[$Line]=mat;Protect[Out];mat;)
Then the postfix command //pMatrixForm[#, 3, 3]& will give the requested 2x2 partitioning of a 4x4 matrix. It maybe useful to change the defaults of pMatrixForm from no partitions to central partitions. This would not be hard.
So this is what I came up with. For a matrix M:
M = {{a, b, 0, 0}, {c, d, 0, 0}, {0, 0, x, y}, {0, 0, z, w}};
you construct two list of True/False values (with True for places where you want separators) that take two arguments; first the matrix and second a list of positions for separators.
colSep = Fold[ReplacePart[#1, #2 -> True] &,
Table[False, {First#Dimensions##1 + 1}], #2] &;
rowSep = Fold[ReplacePart[#1, #2 -> True] &,
Table[False, {Last#Dimensions##1 + 1}], #2] &;
Now the partitioned view using Grid[] is made with the use of Dividers:
partMatrix = Grid[#1, Dividers -> {colSep[#1, #2], rowSep[#1, #3]}] &;
This takes three arguments; first the matrix, second the list of positions for column dividers, and third the list of values for row dividers.
In order for it to display nicely you just wrap it in brakets and use MatrixForm:
MatrixForm#{partMatrix[M, {3}, {3}]}
Which does the 2by2 partitioning you mentioned.