Related
Relatively new to Mathematica, so this might be an easy question. With two lists I need to sort both by one of them, while ignoring any non-numeric values
Example:
x={a, b, c, d, e, f, g};
y={-2, Indeterminate, -3, -Infinity, -1, Apples, 5};
(Also have z=Partition[Riffle[x,y], 2] if that's a little bit better to work with)
Result looking for:
xn={g, e, a, c}
yn={5, -1, -2, -3}
(Or zn equivalent from using z)
Here is one way:
Transpose#Reverse#SortBy[Cases[Transpose[{y, x}], {_?NumericQ, _}], First]
which returns
{{5, -1, -2, -3}, {g, e, a, c}}
I've been fiddling with some Mathematica code to join 2 lists but doing some operations on the one list before adding it to the other. So for example I have
list={{1, "A"}, {1, "B"}, {1, "C"}, {2, "D"}, {2, "E"}, {2, "F"}};
p = {};
q = {};
ones = Select[list, #[[1]] == 1 &];
p = Join[{#[[2]], "t"}, p] & /# Reverse[ones];
Table[
q = Join[{{ones[[m, 2]], "t"}}, q];
, {m, Length[ones]}];
twos = Select[list, #[[1]] == 2 &];
p = Join[{{#[[2]], "t"}}, p] & /# Reverse[twos];
Table[
q = Join[{{twos[[m, 2]], "t"}}, q];
, {m, Length[twos]}];
This yields the following values of p and q respectively:
p={{{F, t}, {C, t}, {B, t}, {A, t}}, {{E, t}, {C, t}, {B, t}, {A, t}}, {{D, t}, {C, t}, {B, t}, {A, t}}}
and
q={{F, t}, {E, t}, {D, t}, {C, t}, {B, t}, {A, t}}
From what I can gather, the second time Join is used with the /#or Map function, each list item in p which at the moment is {{C, t}, {B, t}, {A, t}} is applied to the Join function and is added to a list of results. Is there a way to use Map and rather apply the join to the new value of p each time, so as to obtain a result exactly the same as the value of q but achieved with one line of code.
I tried the same line of code using PrependTo instead of Join and it works fine, I assume this is because PrependTo updates the value of p each time the function is called. For example PrependTo[p, {#[[2]], "t"}] & /# twos;
The reason I was trying to do it this was was to determine whether it will be more time efficient to use Join rather then PrependTo. But ran into this problem before I could get an answer.
Another thing I do not quite understand, is why I need to apply Reverse[] to the lists when using Map to achieve the same result as running through the list using a loop. Could someone possibly explain why this is the case?! I would have assumed Map would run through a list forwards. But this behaviour seems to me as though is traversing the list backwards.
Thanks in advance for the help.
Map does traverse the list as you would expect, in a left right direction. I suspect later elements of your code are introducing reversals.
For instance:
Sqrt /# Select[Range#10, OddQ]
gives {1, Sqrt[3], Sqrt[5], Sqrt[7], 3}
If you want to apply some function to the ones from your list and another function to the twos the structure in a functional language might look something like this:
ans=Join[f1 /# Select[myList, #[[1]] == 1 &], f2 /# Select[myList, #[[1]] == 2 &]]
Further from your clarification:
Method 1 to produce q:
Reverse /# Reverse#list /. {2 -> "t", 1 -> "t"}
Method 2:
Reverse#Join[{Last##, "t"} & /# Select[list, #[[1]] == 1 &], {Last##, "t"} & /# Select[list, First## == 2 &]]
I have written code which draws the Sierpinski fractal. It is really slow since it uses recursion. Do any of you know how I could write the same code without recursion in order for it to be quicker? Here is my code:
midpoint[p1_, p2_] := Mean[{p1, p2}]
trianglesurface[A_, B_, C_] := Graphics[Polygon[{A, B, C}]]
sierpinski[A_, B_, C_, 0] := trianglesurface[A, B, C]
sierpinski[A_, B_, C_, n_Integer] :=
Show[
sierpinski[A, midpoint[A, B], midpoint[C, A], n - 1],
sierpinski[B, midpoint[A, B], midpoint[B, C], n - 1],
sierpinski[C, midpoint[C, A], midpoint[C, B], n - 1]
]
edit:
I have written it with the Chaos Game approach in case someone is interested. Thank you for your great answers!
Here is the code:
random[A_, B_, C_] := Module[{a, result},
a = RandomInteger[2];
Which[a == 0, result = A,
a == 1, result = B,
a == 2, result = C]]
Chaos[A_List, B_List, C_List, S_List, n_Integer] :=
Module[{list},
list = NestList[Mean[{random[A, B, C], #}] &,
Mean[{random[A, B, C], S}], n];
ListPlot[list, Axes -> False, PlotStyle -> PointSize[0.001]]]
This uses Scale and Translate in combination with Nest to create the list of triangles.
Manipulate[
Graphics[{Nest[
Translate[Scale[#, 1/2, {0, 0}], pts/2] &, {Polygon[pts]}, depth]},
PlotRange -> {{0, 1}, {0, 1}}, PlotRangePadding -> .2],
{{pts, {{0, 0}, {1, 0}, {1/2, 1}}}, Locator},
{{depth, 4}, Range[7]}]
If you would like a high-quality approximation of the Sierpinski triangle, you can use an approach called the chaos game. The idea is as follows - pick three points that you wish to define as the vertices of the Sierpinski triangle and choose one of those points randomly. Then, repeat the following procedure as long as you'd like:
Choose a random vertex of the trangle.
Move from the current point to the halfway point between its current location and that vertex of the triangle.
Plot a pixel at that point.
As you can see at this animation, this procedure will eventually trace out a high-resolution version of the triangle. If you'd like, you can multithread it to have multiple processes plotting pixels at once, which will end up drawing the triangle more quickly.
Alternatively, if you just want to translate your recursive code into iterative code, one option would be to use a worklist approach. Maintain a stack (or queue) that contains a collection of records, each of which holds the vertices of the triangle and the number n. Initially put into this worklist the vertices of the main triangle and the fractal depth. Then:
While the worklist is not empty:
Remove the first element from the worklist.
If its n value is not zero:
Draw the triangle connecting the midpoints of the triangle.
For each subtriangle, add that triangle with n-value n - 1 to the worklist.
This essentially simulates the recursion iteratively.
Hope this helps!
You may try
l = {{{{0, 1}, {1, 0}, {0, 0}}, 8}};
g = {};
While [l != {},
k = l[[1, 1]];
n = l[[1, 2]];
l = Rest[l];
If[n != 0,
AppendTo[g, k];
(AppendTo[l, {{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1}] & ## #) & /#
NestList[RotateLeft, k, 2]
]]
Show#Graphics[{EdgeForm[Thin], Pink,Polygon#g}]
And then replace the AppendTo by something more efficient. See for example https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile
Edit
Faster:
f[1] = {{{0, 1}, {1, 0}, {0, 0}}, 8};
i = 1;
g = {};
While[i != 0,
k = f[i][[1]];
n = f[i][[2]];
i--;
If[n != 0,
g = Join[g, k];
{f[i + 1], f[i + 2], f[i + 3]} =
({{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1} & ## #) & /#
NestList[RotateLeft, k, 2];
i = i + 3
]]
Show#Graphics[{EdgeForm[Thin], Pink, Polygon#g}]
Since the triangle-based functions have already been well covered, here is a raster based approach.
This iteratively constructs pascal's triangle, then takes modulo 2 and plots the result.
NestList[{0, ##} + {##, 0} & ## # &, {1}, 511] ~Mod~ 2 // ArrayPlot
Clear["`*"];
sierpinski[{a_, b_, c_}] :=
With[{ab = (a + b)/2, bc = (b + c)/2, ca = (a + c)/2},
{{a, ab, ca}, {ab, b, bc}, {ca, bc, c}}];
pts = {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} // N;
n = 5;
d = Nest[Join ## sierpinski /# # &, {pts}, n]; // AbsoluteTiming
Graphics[{EdgeForm#Black, Polygon#d}]
(*sierpinski=Map[Mean, Tuples[#,2]~Partition~3 ,{2}]&;*)
Here is a 3D version,https://mathematica.stackexchange.com/questions/22256/how-can-i-compile-this-function
ListPlot#NestList[(# + RandomChoice[{{0, 0}, {2, 0}, {1, 2}}])/2 &,
N#{0, 0}, 10^4]
With[{data =
NestList[(# + RandomChoice#{{0, 0}, {1, 0}, {.5, .8}})/2 &,
N#{0, 0}, 10^4]},
Graphics[Point[data,
VertexColors -> ({1, #[[1]], #[[2]]} & /# Rescale#data)]]
]
With[{v = {{0, 0, 0.6}, {-0.3, -0.5, -0.2}, {-0.3, 0.5, -0.2}, {0.6,
0, -0.2}}},
ListPointPlot3D[
NestList[(# + RandomChoice[v])/2 &, N#{0, 0, 0}, 10^4],
BoxRatios -> 1, ColorFunction -> "Pastel"]
]
Is there a pre-canned operation that would take two lists, say
a = { 1, 2, 3 }
b = { 2, 4, 8 }
and produce, without using a for loop, a new list where corresponding elements in each pair of lists have been multiplied
{ a[1] b[1], a[2] b[2], a[3] b[3] }
I was thinking there probably exists something like Inner[Times, a, b, Plus], but returns a list instead of a sum.
a = {1, 2, 3}
b = {2, 4, 8}
Thread[Times[a, b]]
Or, since Times[] threads element-wise over lists, simply:
a b
Please note that the efficiency of the two solutions is not the same:
i = RandomInteger[ 10, {5 10^7} ];
{First[ Timing [i i]], First[ Timing[ Thread[ Times [i,i]]]]}
(*
-> {0.422, 1.235}
*)
Edit
The behavior of Times[] is due to the Listable attribute. Look at this:
SetAttributes[f,Listable];
f[{1,2,3},{3,4,5}]
(*
-> {f[1,3],f[2,4],f[3,5]}
*)
You can do this using Inner by using List as the last argument:
In[5]:= Inner[Times, a, b, List]
Out[5]= {2, 8, 24}
but as others already mentioned, Times works automatically. In general for things like Inner, it's frequently useful to test things with "dummy" functions to see what the structure is:
In[7]:= Inner[f, a, b, g]
Out[7]= g[f[1, 2], f[2, 4], f[3, 8]]
and then work backwards from that to determine what the actual functions should be to give the desired result.
I have two arrays, say A={1, 2, 3} and B={2, 4, 8} (array item count and numbers may vary). How do I find a bijection between the arrays.
In this case, it would be f:A->B; f(x)=2^(x)
I don't think this problem has a general solution. You may try FindSequenceFunction, but it will not always find the solution. For the case at hand, you'd need a bit longer lists:
In[250]:= FindSequenceFunction[Transpose[{{1, 2, 3}, {2, 4, 8}}], n]
Out[250]= FindSequenceFunction[{{1, 2}, {2, 4}, {3, 8}}, n]
but
In[251]:= FindSequenceFunction[Transpose[{{1, 2, 3, 4}, {2, 4, 8, 16}}], n]
Out[251]= 2^n
You can also play with FindFit, if you have some guesses about the bijection:
In[252]:= FindFit[Transpose[{{1, 2, 3}, {2, 4, 8}}], p*q^x, {p, q}, x]
Out[252]= {p -> 1., q -> 2.}
As others have remarked, this problem is ill-defined.
Other possible functions that give the same results are (among probably infinite others): (8 x)/3 - x^2 + x^3/3, x + (37 x^2)/18 - (4 x^3)/3 + (5 x^4)/18, and (259 x^3)/54 - (31 x^4)/9 + (35 x^5)/54.
I found these solutions using:
n = 5; (* try various other values *)
A = {1, 2, 3} ; B = {2, 4, 8}
eqs = Table[
Sum[a[i] x[[1]]^i, {i, n}] == x[[2]], {x, {A, B}\[Transpose]}]
sol = Solve[eqs, Table[a[i], {i, n}], Reals]
Sum[a[i] x^i, {i, n}] /. sol
Sometimes not all of the a[i]'s are fully determined and you may come up with values of your own.
[tip: better not use variables starting with a capital letter in Mathematica so as not to get into conflict with reserved words]
Since you tag Mathematica, I'll use Mathematica functions as a reference.
If you are interested in an arbitrary fit of your data with a smooth function, you can use Interpolation. E.g.
a = {1, 2, 3}; b = {2, 4, 8};
f = Interpolation[Transpose[{a, b}]];
(* Graph the interpolation function *)
Show[Plot[f[x], {x, 1, 3}], Graphics[Point /# Transpose[{a, b}]],
PlotRange -> {{0, 4}, {0, 9}}, Frame -> Automatic, Axes -> None]
Interpolation uses piecewise polynomials. You can do the same in your favorite programming language if you happen know or are willing to learn a bit about numerical methods, especially B-Splines.
If instead you know something about your data, e.g. that it is of the form c d^x, then you can do a minimization to find the unknowns (c and d in this case). If your data is in fact generated from the form c d^x, then the fit will be fairly, otherwise it's the error is minimized in the least-squares sense. So for your data:
FindFit[Transpose[{a, b}], c d^x, {c, d}, {x}]
reports:
{c -> 1., d -> 2.}
Indicating that your function is 2^x, just as you knew all along.