Related
In Mathematica there are a number of functions that return not only the final result or a single match, but all results. Such functions are named *List. Exhibit:
FoldList
NestList
ReplaceList
ComposeList
Something that I am missing is a MapList function.
For example, I want:
MapList[f, {1, 2, 3, 4}]
{{f[1], 2, 3, 4}, {1, f[2], 3, 4}, {1, 2, f[3], 4}, {1, 2, 3, f[4]}}
I want a list element for each application of the function:
MapList[
f,
{h[1, 2], {4, Sin[x]}},
{2}
] // Column
{h[f[1], 2], {4, Sin[x]}}
{h[1, f[2]], {4, Sin[x]}}
{h[1, 2], {f[4], Sin[x]}}
{h[1, 2], {4, f[Sin[x]]}}
One may implement this as:
MapList[f_, expr_, level_: 1] :=
MapAt[f, expr, #] & /#
Position[expr, _, level, Heads -> False]
However, it is quite inefficient. Consider this simple case, and compare these timings:
a = Range#1000;
#^2 & /# a // timeAvg
MapList[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
0.00005088
0.01436
0.0003744
This illustrates that on average MapList is about 38X slower than the combined total of mapping the function to every element in the list and creating a 1000x1000 array.
Therefore, how may MapList be most efficiently implemented?
I suspect that MapList is nearing the performance limit for any transformation that performs structural modification. The existing target benchmarks are not really fair comparisons. The Map example is creating a simple vector of integers. The ConstantArray example is creating a simple vector of shared references to the same list. MapList shows poorly against these examples because it is creating a vector where each element is a freshly generated, unshared, data structure.
I have added two more benchmarks below. In both cases each element of the result is a packed array. The Array case generates new elements by performing Listable addition on a. The Module case generates new elements by replacing a single value in a copy of a. These results are as follows:
In[8]:= a = Range#1000;
#^2 & /# a // timeAvg
MapList[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
Array[a+# &, 1000] // timeAvg
Module[{c}, Table[c = a; c[[i]] = c[[i]]^2; c, {i, 1000}]] // timeAvg
Out[9]= 0.0005504
Out[10]= 0.0966
Out[11]= 0.003624
Out[12]= 0.0156
Out[13]= 0.02308
Note how the new benchmarks perform much more like MapList and less like the Map or ConstantArray examples. This seems to show that there is not much scope for dramatically improving the performance of MapList without some deep kernel magic. We can shave a bit of time from MapList thus:
MapListWR4[f_, expr_, level_: {1}] :=
Module[{positions, replacements}
, positions = Position[expr, _, level, Heads -> False]
; replacements = # -> f[Extract[expr, #]] & /# positions
; ReplacePart[expr, #] & /# replacements
]
Which yields these timings:
In[15]:= a = Range#1000;
#^2 & /# a // timeAvg
MapListWR4[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
Array[a+# &, 1000] // timeAvg
Module[{c}, Table[c = a; c[[i]] = c[[i]]^2; c, {i, 1000}]] // timeAvg
Out[16]= 0.0005488
Out[17]= 0.04056
Out[18]= 0.003
Out[19]= 0.015
Out[20]= 0.02372
This comes within factor 2 of the Module case and I expect that further micro-optimizations can close the gap yet more. But it is with eager anticipation that I join you awaiting an answer that shows a further tenfold improvement.
(Updated my function)
I think I can offer another 2x boost on top of WReach's attempt.
Remove[MapListTelefunken];
MapListTelefunken[f_, dims_] :=
With[{a = Range[dims], fun = f[[1]]},
With[{replace = ({#, #} -> fun) & /# a},
ReplacePart[ConstantArray[a, {dims}], replace]
]
]
Here are the timings on my machine (Sony Z laptop; i7, 8GB ram, 256 SSD in Raid 0):
a = Range#1000;
#^2 & /# a; // timeAvg
MapList[#^2 &, a]; // timeAvg
MapListWR4[#^2 &, a]; // timeAvg
MapListTelefunken[#^2 &, 1000]; // timeAvg
0.0000296 (* just Mapping the function over a Range[1000] for baseline *)
0.0297 (* the original MapList proposed by Mr.Wizard *)
0.00936 (* MapListWR4 from WReach *)
0.00468 (* my attempt *)
I think you'd still need to create the 1000x1000 array, and I don't think there's any cleverer way than a constant array. More to the point, your examples are better served with the following definition, although I admit that it lacks the finesse of levels.
MapList[f_, list_] := (Table[MapAt[f, #, i], {i, Length##}] &)#list;
The culprit in your own definition is the Position[] call, which creates a complex auxiliary structure.
Provide a more complex use case, that will better cover your intentions.
In Mathematica, Max[] is the most efficient function to get the maximum number in a list of numbers, but how do I find the list with the maximum last element in a list of lists? e.g. the 2-d coordinate with the biggest x part in a series of coordinates.
My best try is SortBy, but obviously I don't need the program to sort my list, only the maximum one I need.
Perhaps:
list = {{4, 3}, {5, 10}, {-2, 1}, {3, 7}}
Reverse /# Take[#, Ordering[#, -1]] &#(Reverse /# #) &# list
(*
-> {{5, 10}}
*)
Exploiting the fact that Ordering[ ] orders lists by their first element
Edit
Or much better (I think):
Take[#, Ordering[Last /# #, -1]] &# list
Edit
Also:
#[[Ordering[#, -1, Last##2 > Last##1 &]]] &#list
Edit
Perhaps faster:
#[[First#Position[#, Max##] &#(Last /# #)]] &#list
Here is my approach using Pick
maxBy[list_, n_] := With[{s = list[[All, n]]}, Pick[list, s, Max[s]]]
maxBy[{{4, 3}, {5, 10}, {-2, 1}, {3, 7}}, 2]
(* output:
{{5, 10}}
*)
This version works on any number of elements per sublist provided n is less than or equal to the length of the shortest sublist.
Timings for this version on my machine
list2 = RandomInteger[{-10^7, 10^7}, {10^6, 2}];
list3 = RandomInteger[{-10^7, 10^7}, {10^6, 3}];
list9 = RandomInteger[{-10^7, 10^7}, {10^6, 9}];
maxBy[list2, 2]; // Timing
maxBy[list3, 2]; // Timing
maxBy[list9, 2]; // Timing
(* output:
{0.030341, Null}
{0.030912, Null}
{0.033313, Null}
*)
Compared to David's code
maxBy[list2, 2]; // Timing
maxBy[list3, 2]; // Timing
maxBy[list9, 2]; // Timing
(* ouput:
{0.186175, Null}
{0.184989, Null}
{0.262018, Null}
*)
Yoda's code
maxBy[list2, 2]; // Timing
maxBy[list3, 2]; // Timing
maxBy[list9, 2]; // Timing
(* ouput:
{0.944016, Null}
{0.83094, Null}
{0.874126, Null}
*)
And belisarius' code
Reverse /# Take[#, Ordering[#, -1]] &#(Reverse /# #) &#list2; // Timing
Take[#, Ordering[Last /# #, -1]] &#list2; // Timing
#[[Ordering[#, -1, Last##2 > Last##1 &]]] &#list2; // Timing
#[[First#Position[#, Max##] &#(Last /# #)]] &#list2; // Timing
(* output:
{0.211016, Null}
{0.099253, Null}
{2.03415, Null}
{0.266934, Null}
*)
Not the most efficient but simpler?
max = Max#list[[All, -1]];
Cases[list, {_, max}]
or
max = Max#list3[[All, -1]];
Cases[list3, {_,_, max}]
Usage
list = {{40, 3}, {5, 10}, {-2, 1}, {3, 10}}
max = Max#list[[All, -1]];
Cases[list, {_, max}]
Output:
{{5, 10}, {3, 10}}
How about this function (defined here only for 2D lists):
maxBy = Module[{pattern = Reverse#Insert[{Max##1[[All, #2]]}, _, #2]},
Cases[#1, pattern]] &
Example:
list = {{4, 3}, {5, 10}, {20, 1}, {3, 7}};
maxBy[list, 1]
Out[1]= {{20, 1}}
maxBy[list, 2]
Out[2]= {{5, 10}}
Here's an approach that relies on Transpose:
maxBy = #1[[Position[t = Transpose[#1][[#2]], Max[t]][[All, 1]]]] &;
For example:
list = {{4, 3}, {5, 10}, {20, 1}, {3, 7}};
maxBy[list, 1]
(* {{20, 1}} *)
maxBy[list, 2]
(* {{5, 10}} *)
It can handle more than two elements per sublist, provided that the sublists are all the same length.
r:=RandomInteger[{-10^5,10^5}];
list3=Table[{r,r,r},{j,10^2}]; (* 3 numbers in each sublist *)
list9=Table[{r,r,r,r,r,r,r,r,r},{j,10^2}]; (* 9 numbers *)
maxBy[list3, 2] (* Find max in position 2 of list3 *)
(* {{-93332, 99582, 4324}} *)
maxBy[list9, 5] (* Find max in position 5 of list9 *)
(* {{7680, 85508, 51915, -58282, 94679, 50968, -12664, 75246, -82903}} *)
Of course, the results will vary according to the random numbers you have generated.
Edit
Here's some timing data for large lists. SortBy is clearly slower. but doesn't seem as influenced by the number of elements in each sublist. First, my maxBy code followed by SortBy:
Using the same list2, here's some timing data for Yoda's code. Although his routine is also called maxBy, it is his that produced the output that follows:
Again, with the same list2, some data for Belisarius' code:
His second suggestion is the fastest of all tested.
After reading some documentations and doing a few experiments, I managed to get a clearer view of this problem.
I actually was wondering why Max[] seemed intentionally avoid providing directives that make it return not only the max element itself, but also its position. After all, providing position doesn't change the O(n) complexity of the algorithm. For example, imagine:
In[1]:= Max[{991, 993, 992}, ReturnPosition -> True]
Out[1]= {2}
If that could be done, you can simply use the code below to solve my problem:
list[[Max[list[[All, -1]], ReturnPosition -> True]]]
But now I realize that the system function Max[] is not designed for finding the max element in lists. You can tell that the Wolfram team obviously made Max[] more like a traditional max function in mathematics ― it does simple symbolic simplifications, it automatically flatten out all lists, it can be in a plotable function, and most importantly, it's Orderless:
In[2]:= Attributes[Max]
Out[2]= {Flat, NumericFunction, OneIdentity, Orderless, Protected}
Which makes positions meaningless. In a word, it treats all the lists inside as mathematical sets.
So philosophically it's not trivial for Mathematica to compute this. All I need to do is to "DIY" a function with the O(n) complexity and can do the job. I think TomD is heading the right direction, although I prefer:
maxLast[l_] := Cases[l, {___, Max[Last/#l]}]
And Heike (黑客?) adopted Pick which may have better techniques especially designed for selecting elements, but there must be no virtual difference in the complexity of the algorithm. And I may rewrite it this way: (fewer names and heads, faster the speed)
maxLast[l_] := Pick[l, #, Max[#]] &[Last /# l]
They're both good answers.
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}
The Table[ ] command usually returns a list with the same cardinality of its iterator.
Table[i, {i,4}]
(*
->{1,2,3,4}
*)
It is easy to show that is possible to return a list with a greater cardinality than the iterator
Table[Sequence ## ConstantArray[1, i], {i, 2}]
(*
->{1,1,1}
*)
But ... Are there ways to return a list with LESS cardinality than the iterator?
This should work:
Table[Sequence ## {}, {i, 10}]
Assuming that I now understand your intent, I do not see the advantage to "on the fly" elimination within Table itself. One could accomplish it with something like:
Table[If[EvenQ#i, i, ##&[]], {i, 25}]
but it is faster to use Join:
Join ## Table[If[EvenQ#i, {i}, {}], {i, 25}]
or DeleteCases:
DeleteCases[Table[If[EvenQ#i, i], {i, 25}], , 1]
and in this simple case, Select is more than twice as fast:
Table[i, {i, 25}] ~Select~ EvenQ
If it is a matter of memory usage, the first method using Sequence does come out ahead, but the Join method is not far behind.
A simple example:
Table[Sequence ## ConstantArray[1, i - 1], {i, 2}]
Out[1] = {1}
This need not always return a list with smaller cardinality. For e.g., {i,3} returns equal and {i,4} returns more.
Or an even sillier example would be
Table[Sequence ## {}, {i, 2}]
but I don't know if it counts.
You could also use Piecewise inside Table
Table[Sequence ## Piecewise[{
{ConstantArray[1, i], i < 3},
{ConstantArray[2, i], 3 <= i < 5},
{{}, i >= 5}}],
{i, 20}]
Out[2] = {1, 1, 1, 2, 2, 2, 2, 2, 2, 2}
I have a list of pairs of values in mathematica, for example List= {{3,1},{5,4}}.
How do I change the first element (3 & 5) if the second element does not reach a threshold. For example, if the second parts are below 2 then i wish the first parts to go to zero. so that list then = {{0,1},{5,4}}. Some of these lists are extremely long so manually doing it is not an option, unfortunately.
Conceptually, the general way is to use Map. In your case, the code would be
In[13]:= lst = {{3, 1}, {5, 4}}
Out[13]= {{3, 1}, {5, 4}}
In[14]:= thr = 2
Out[14]= 2
In[15]:= Map[{If[#[[2]] < thr, 0, #[[1]]], #[[2]]} &, lst]
Out[15]= {{0, 1}, {5, 4}}
The # symbol here stands for the function argument. You can read more on pure functions here. Double square brackets stand for the Part extraction. You can make it a bit more concise by using Apply on level 1, which is abbreviated by ###:
In[27]:= {If[#2 < thr, 0, #], #2} & ### lst
Out[27]= {{0, 1}, {5, 4}}
Note however that the first method is several times faster for large numerical lists. An even faster, but somewhat more obscure method is this:
In[29]:= Transpose[{#[[All, 1]]*UnitStep[#[[All, 2]] - thr], #[[All, 2]]}] &[lst]
Out[29]= {{0, 1}, {5, 4}}
It is faster because it uses very optimized vectorized operations which apply to all sub-lists at once. Finally, if you want the ultimate performance, this procedural compiled to C version will be another factor of 2 faster:
fn = Compile[{{lst, _Integer, 2}, {threshold, _Real}},
Module[{copy = lst, i = 1},
For[i = 1, i <= Length[lst], i++,
If[copy[[i, 2]] < threshold, copy[[i, 1]] = 0]];
copy], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
You use it as
In[32]:= fn[lst, 2]
Out[32]= {{0, 1}, {5, 4}}
For this last one, you need a C compiler installed on your machine.
Another alternative: Apply (###, Apply at level 1) and Boole (turns logical values in 1's and 0's):
lst = {{3, 1}, {5, 4}};
{#1 Boole[#2 >= 2], #2} & ### lst
An alternative approach might be to use substitution rules, and attach a condition (/;)
lst = {{3, 1}, {5, 4}};
lst /. {x_, y_ /; y < 2} -> {0, y}
output:
{{0, 1}, {5, 4}}
Assuming that your matrix is 2x2 and by second elemnt you mean the second row:
This should work:
If[A[[2, 1]] < 2 || A[[2, 2]] < 2, A[[2,1]] = 0 ]; A
You may have to change the variables, since your questions is kind of confusing. But that's the idea ;-)