Related
In Mathematica, calling Solve, returns a list of rules, e.g.,
In[1]:= g = Solve[(x - 1) (x - 2) == 0, x]
Out[1]= {{x -> 1}, {x -> 2}}
How can I extract the numerical values 1 or 2 from g?
I tried using Part e.g., g[[1]] but it returns {x -> 1} and not 1.
Please advise.
To complement Belisarius' answer,
x /. g
with g = {{x -> 1}, {x -> 2}}, returns the list
{1, 2}
So to extract the first value, 1, we could use
First[x /. g]
Other alternatives are
x /. g[[1]]
(x /. g)[[1]] (* this is equivalent to the version using First *)
g[[1,1,2]]
x /. g[[1]]
Filler -> Thirty chars minimum
Given pairs of coordinates
data = {{1, 0}, {2, 0}, {3, 1}, {4, 2}, {5, 1},
{6, 2}, {7, 3}, {8, 4}, {9, 3}, {10, 2}}
I'd like to extract peaks and valleys, thus:
{{4, 2}, {5, 1}, {8, 4}}
My current solution is this clumsiness:
Cases[
Partition[data, 3, 1],
{{ta_, a_}, {tb_, b_}, {tc_, c_}} /; Or[a < b > c, a > b < c] :> {tb, b}
]
which you can see starts out by tripling the size of the data set using Partition. I think it's possible to use Cases and PatternSequence to extract this information, but this attempt doesn't work:
Cases[
data,
({___, PatternSequence[{_, a_}, {t_, b_}, {_, c_}], ___}
/; Or[a < b > c, a > b < c]) :> {t, b}
]
That yields {}.
I don't think anything is wrong with the pattern because it works with ReplaceAll:
data /. ({___, PatternSequence[{_, a_}, {t_, b_}, {_, c_}], ___}
/; Or[a < b > c, a > b < c]) :> {t, b}
That gives the correct first peak, {4, 2}. What's going on here?
One of the reasons why your failed attempt doesn't work is that Cases by default looks for matches on level 1 of your expression. Since your looking for matches on level 0 you would need to do something like
Cases[
data,
{___, {_, a_}, {t_, b_}, {_, c_}, ___} /; Or[a < b > c, a > b < c] :> {t, b},
{0}
]
However, this only returns {4,2} as a solution so it's still not what you're looking for.
To find all matches without partitioning you could do something like
ReplaceList[data, ({___, {_, a_}, {t_, b_}, {_, c_}, ___} /;
Or[a < b > c, a > b < c]) :> {t, b}]
which returns
{{4, 2}, {5, 1}, {8, 4}}
Your "clumsy" solution is fairly fast, because it heavily restricts what gets looked at.
Here is an example.
m = 10^4;
n = 10^6;
ll = Transpose[{Range[n], RandomInteger[m, n]}];
In[266]:=
Timing[extrema =
Cases[Partition[ll, 3,
1], {{ta_, a_}, {tb_, b_}, {tc_, c_}} /;
Or[a < b > c, a > b < c] :> {tb, b}];][[1]]
Out[266]= 3.88
In[267]:= Length[extrema]
Out[267]= 666463
This seems to be faster than using replacement rules.
Faster still is to create a sign table of products of differences. Then pick entries not on the ends of the list that correspond to sign products of 1.
In[268]:= Timing[ordinates = ll[[All, 2]];
signs =
Table[Sign[(ordinates[[j + 1]] -
ordinates[[j]])*(ordinates[[j - 1]] - ordinates[[j]])], {j, 2,
Length[ll] - 1}];
extrema2 = Pick[ll[[2 ;; -2]], signs, 1];][[1]]
Out[268]= 0.23
In[269]:= extrema2 === extrema
Out[269]= True
Handling of consecutive equal ordinates is not considered in these methods. Doing that would take more work since one must consider neighborhoods larger than three consecutive elements. (My spell checker wants me to add a 'u' to the middle syllable of "neighborhoods". My spell checker must think we are in Canada.)
Daniel Lichtblau
Another alternative:
Part[#,Flatten[Position[Differences[Sign[Differences[#[[All, 2]]]]], 2|-2] + 1]] &#data
(* ==> {{4, 2}, {5, 1}, {8, 4}} *)
Extract[#, Position[Differences[Sign[Differences[#]]], {_, 2} | {_, -2}] + 1] &#data
(* ==> {{4, 2}, {5, 1}, {8, 4}} *)
This may be not exactly the implementation you ask, but along those lines:
ClearAll[localMaxPositions];
localMaxPositions[lst : {___?NumericQ}] :=
Part[#, All, 2] &#
ReplaceList[
MapIndexed[List, lst],
{___, {x_, _}, y : {t_, _} .., {z_, _}, ___} /; x < t && z < t :> y];
Example:
In[2]:= test = RandomInteger[{1,20},30]
Out[2]= {13,9,5,9,3,20,2,5,18,13,2,20,13,12,4,7,16,14,8,16,19,20,5,18,3,15,8,8,12,9}
In[3]:= localMaxPositions[test]
Out[3]= {{4},{6},{9},{12},{17},{22},{24},{26},{29}}
Once you have positions, you may extract the elements:
In[4]:= Extract[test,%]
Out[4]= {9,20,18,20,16,20,18,15,12}
Note that this will also work for plateau-s where you have more than one same maximal element in a row. To get minima, one needs to trivially change the code. I actually think that ReplaceList is a better choice than Cases here.
To use it with your data:
In[7]:= Extract[data,localMaxPositions[data[[All,2]]]]
Out[7]= {{4,2},{8,4}}
and the same for the minima. If you want to combine, the change in the above rule is also trivial.
Since one of your primary concerns about your "clumsy" method is the data expansion that takes place with Partition, you may care to know about the Developer` function PartitionMap, which does not partition all the data at once. I use Sequence[] to delete the elements that I don't want.
Developer`PartitionMap[
# /. {{{_, a_}, x : {_, b_}, {_, c_}} /; a < b > c || a > b < c :> x,
_ :> Sequence[]} &,
data, 3, 1
]
A light-weight question for the experts. I can't seem to figure the correct syntax to this replacement. I have this list
Clear[a, b, c, d]
polesList = {{3, {a, b}}, {5, {c, d}}};
It is of the form of a list with sublists each have the form {order,{x,y}} and I want to generate a new list of this form (x+y)^order
Currently this is what I do, which works:
((#[[2, 1]] + #[[2, 2]])^#[[1]]) & /# polesList
(* -----> {(a + b)^3, (c + d)^5} *)
But I have been trying to learn to use ReplaceAll as it is more clear to me than pure functions, since I can see the pattern better, like this:
Clear[a, b, c, d, n]
polesList = {{3, {a, b}}, {5, {c, d}}};
ReplaceAll[polesList, {n_, {x_, y_}} :> (x + y)^n] (*I thought this will work*)
I get strange result, which is
{(5 + c)^3, {(5 + d)^a, (5 + d)^b}}
What is the correct syntax to do this replacement using ReplaceAll instead of the pure function method?
Thanks
Update:
I find that using Replace, instead of ReplaceAll works, but need to say {1} at the end:
Clear[a, b, c, d, n]
polesList = {{3, {a, b}}, {5, {c, d}}};
Replace[polesList, {n_, {x_, y_}} :> (x + y)^n, {1}]
which gives
{(a + b)^3, (c + d)^5}
But ReplaceAll does not take {1} at the end. I am more confused now which to use :)
The problem is that ReplaceAll inspects all levels of the expression when looking for replacements. The entire expression matches the pattern {n_, {x_, y_}} where:
n matches {3, {a, b}}
x matches 5
y matches {c, d}
So you end up with (5 + {c , d}) ^ {3, {a, b}} which evaluates to the result you see.
There are a few ways to fix this. First, you can change the pattern so that it does not match the outermost list. For example, if the n values are always integers you could use:
ReplaceAll[polesList, {n_Integer, {x_, y_}} :> (x + y)^n]
Or, you could use Replace instead of ReplaceAll, and restrict the pattern matching the first level only:
Replace[polesList, {n_, {x_, y_}} :> (x + y)^n, {1}]
I find that applying replacement rules to the first level of a list is very common. It so happens that Cases, by default, only operates on that level. So I find myself frequently using Cases for level one replacements when I know that all elements will match the pattern:
Cases[polesList, {n_, {x_, y_}} :> (x + y)^n]
This last expression is how I would probably write the desired replacement. Keep in mind, though, that if all elements do not match the pattern, then the Cases approach will drop the mismatches from the result.
The problem is that ReplaceAll looks at all levels in the expression and the first match to the pattern
{n_, {x_, y_}}
in the expression {{3, {a, b}}, {5, {c, d}}} is
{ n=={3, {a, b}}, {x==5, y=={c, d}}}
(if that notation is clear)
So you got the "strange" result
(5 + {c,d})^{3, {a, b}} == {5+c, 5+d}^{3, {a, b}}
== {(5+c)^3, (5+d)^{a, b}} == {(5+c)^3, {(5+d)^a,(5+d)^b}}
The easiest fix, if n is always numeric, is
In[2]:= {{3, {a, b}}, {5, {c, d}}} /. {n_?NumericQ, {x_, y_}} :> (x + y)^n
Out[2]= {(a + b)^3, (c + d)^5}
Where I used the shorthand /. for ReplaceAll.
It might be that using Replace at level 1 is the best option
In[3]:= Replace[{{3, {a, b}}, {5, {c, d}}}, {n_,{x_,y_}}:>(x+y)^n, {1}]
Out[3]= {(a+b)^3,(c+d)^5}
which should be compared with the default replace that works at the top level {0}
In[4]:= Replace[{{3, {a, b}}, {5, {c, d}}}, {n_,{x_,y_}}:>(x+y)^n]
Out[4]= {(5+c)^3,{(5+d)^a,(5+d)^b}}
You could also use ReplaceAll[ ] with Map:
Map[ReplaceAll[#, {n_, {x_, y_}} :> (x + y)^n] &, polesList]
or (using shorthands increasingly)
ReplaceAll[#, {n_, {x_, y_}} :> (x + y)^n] & /# polesList
or
# /. {n_, {x_, y_}} :> (x + y)^n & /# polesList
In previous thread an efficient way to remove empty lists ({}) from lists was suggested:
Replace[expr, x_List :> DeleteCases[x, {}], {0, Infinity}]
Using the Trott-Strzebonski in-place evaluation technique this method can be generalized for working also with held expressions:
f1[expr_] :=
Replace[expr,
x_List :> With[{eval = DeleteCases[x, {}]}, eval /; True], {0, Infinity}]
This solution is more efficient than the one based on ReplaceRepeated:
f2[expr_] := expr //. {left___, {}, right___} :> {left, right}
But it has one disadvantage: it evaluates held expressions if they are wrapped by List:
In[20]:= f1[Hold[{{}, 1 + 1}]]
Out[20]= Hold[{2}]
So my question is: what is the most efficient way to remove all empty lists ({}) from lists without evaluating held expressions? The empty List[] object should be removed only if it is an element of another List itself.
Here are some timings:
In[76]:= expr = Tuples[Tuples[{{}, {}}, 3], 4];
First#Timing[#[expr]] & /# {f1, f2, f3}
pl = Plot3D[Sin[x y], {x, 0, Pi}, {y, 0, Pi}];
First#Timing[#[pl]] & /# {f1, f2, f3}
Out[77]= {0.581, 0.901, 5.027}
Out[78]= {0.12, 0.21, 0.18}
Definitions:
Clear[f1, f2, f3];
f3[expr_] :=
FixedPoint[
Function[e, Replace[e, {a___, {}, b___} :> {a, b}, {0, Infinity}]], expr];
f1[expr_] :=
Replace[expr,
x_List :> With[{eval = DeleteCases[x, {}]}, eval /; True], {0, Infinity}];
f2[expr_] := expr //. {left___, {}, right___} :> {left, right};
How about:
Clear[f3];
f3[expr_] :=
FixedPoint[
Function[e,
Replace[e, {a___, {}, b___} :> {a, b}, {0, Infinity}]],
expr]
It seems to live up to the specs:
In[275]:= f3[{a, {}, {b, {}}, c[d, {}]}]
Out[275]= {a, {b}, c[d, {}]}
In[276]:= f3[Hold[{{}, 1 + 1, {}}]]
Out[276]= Hold[{1 + 1}]
You can combine the solutions you mentioned with a minimal performance hit and maintain the code unevaluated by using a technique from this post, with a modification that the custom holding wrapper will be made private by using Module:
ClearAll[removeEmptyListsHeld];
removeEmptyListsHeld[expr_Hold] :=
Module[{myHold},
SetAttributes[myHold, HoldAllComplete];
Replace[MapAll[myHold, expr, Heads -> True],
x : myHold[List][___] :>
With[{eval = DeleteCases[x, myHold[myHold[List][]]]},
eval /; True],
{0, Infinity}]//. myHold[x_] :> x];
The above function assumes that the input expression is wrapped in Hold. Examples:
In[53]:= expr = Tuples[Tuples[{{}, {}}, 3], 4];
First#Timing[#[expr]] & /# {f1, f2, f3, removeEmptyListsHeld[Hold[#]] &}
Out[54]= {0.235, 0.218, 1.75, 0.328}
In[56]:= removeEmptyListsHeld[Hold[{{},1+1,{}}]]
Out[56]= Hold[{1+1}]
I'm just a bit late with this one. ;-)
Though rather complicated this tests about an order of magnitude faster than your f1:
fx[expr_] :=
Module[{s},
expr //
Quiet[{s} /. {x_} :> ({} /. {x___} -> (# /. {} -> x //. {x ..} -> x) &)]
]
It does not evaluate:
Hold[{{}, 1 + 1}] // fx
Hold[{1 + 1}]
Timings
expr = Tuples[Tuples[{{}, {}}, 3], 4];
First # Timing # Do[# # expr, {100}] & /# {f1, fx}
pl = Plot3D[Sin[x y], {x, 0, Pi}, {y, 0, Pi}];
First # Timing # Do[# # pl, {100}] & /# {f1, fx}
{10.577, 0.982} (* 10.8x faster *)
{1.778, 0.266} (* 6.7x faster *)
Check
f1#expr === fx#expr
f1#pl === fx#pl
True
True
Explanation
The basic version of this function would look like this:
{} /. {x___} -> (# //. {} | {x ..} -> x) &
The idea is to first reduce the expression with //. {} | {x ..} -> x and then use the injector pattern with an empty expression to remove all instances of x, as though they were replaced with Sequence[] but without evaluation.
The first change is to optimize this somewhat by splitting the replacement into /. {} -> x //. {x ..} -> x. The second change is to somehow localize x in the patterns so that it does not fail if x appears in the expression itself. Because of the way Mathematica handles nested scoping constructs I cannot simply use Module[{x}, . . . ] but instead have to use the injector pattern again to get a unique symbol into x___ etc., and Quiet to keep it from complaining about the nonstandard use.
Many times I find myself counting occurrences with Tally[ ] and then, once I discarded the original list, having to add (and join) to that counters list the results from another list.
This typically happens when I am counting configurations, occurrences, doing some discrete statistics, etc.
So I defined a very simple but handy function for Tally aggregation:
aggTally[listUnTallied__List:{},
listUnTallied1_List,
listTallied_List] :=
Join[Tally#Join[listUnTallied, listUnTallied1], listTallied] //.
{a___, {x_, p_}, b___, {x_, q_}, c___} -> {a, {x, p + q}, b, c};
Such that
l = {x, y, z}; lt = Tally#l;
n = {x};
m = {x, y, t};
aggTally[n, {}]
{{x, 1}}
aggTally[m, n, {}]
{{x, 2}, {y, 1}, {t, 1}}
aggTally[m, n, lt]
{{x, 3}, {y, 2}, {t, 1}, {z, 1}}
This function has two problems:
1) Performance
Timing[Fold[aggTally[Range##2, #1] &, {}, Range[100]];]
{23.656, Null}
(* functional equivalent to *)
Timing[s = {}; j = 1; While[j < 100, s = aggTally[Range#j, s]; j++]]
{23.047, Null}
2) It does not validate that the last argument is a real Tallied list or null (less important for me, though)
Is there a simple, elegant, faster and more effective solution? (I understand that these are too many requirements, but wishing is free)
Perhaps, this will suit your needs?
aggTallyAlt[listUnTallied__List : {}, listUnTallied1_List, listTallied : {{_, _Integer} ...}] :=
{#[[1, 1]], Total##[[All, 2]]} & /#
GatherBy[Join[Tally#Join[listUnTallied, listUnTallied1], listTallied], First]
The timings are much better, and there is a pattern-based check on the last arg.
EDIT:
Here is a faster version:
aggTallyAlt1[listUnTallied__List : {}, listUnTallied1_List, listTallied : {{_, _Integer} ...}] :=
Transpose[{#[[All, 1, 1]], Total[#[[All, All, 2]], {2}]}] &#
GatherBy[Join[Tally#Join[listUnTallied, listUnTallied1], listTallied], First]
The timings for it:
In[39]:= Timing[Fold[aggTallyAlt1[Range##2, #1] &, {}, Range[100]];]
Timing[s = {}; j = 1; While[j < 100, s = aggTallyAlt1[Range#j, s]; j++]]
Out[39]= {0.015, Null}
Out[40]= {0.016, Null}
The following solution is just a small modification of your original function. It applies Sort before using ReplaceRepeated and can thus use a less general replacement pattern which makes it much faster:
aggTally[listUnTallied__List : {}, listUnTallied1_List,
listTallied : {{_, _Integer} ...}] :=
Sort[Join[Tally#Join[listUnTallied, listUnTallied1],
listTallied]] //. {a___, {x_, p_}, {x_, q_}, c___} -> {a, {x, p + q}, c};
Here's the fastest thing I've come up with yet, (ab)using the tagging available with Sow and Reap:
aggTally5[untallied___List, tallied_List: {}] :=
Last[Reap[
Scan[((Sow[#2, #] &) ### Tally[#]) &, {untallied}];
Sow[#2, #] & ### tallied;
, _, {#, Total[#2]} &]]
Not going to win any beauty contests, but it's all about speed, right? =)
If you stay purely symbolic, you may try something along the lines of
(Plus ## Times ### Join[#1, #2] /. Plus -> List /. Times -> List) &
for joining tally lists. This is stupid fast but returns something that isn't a tally list, so it needs some work (after which it may not be so fast anymore ;) ).
EDIT: So I've got a working version:
aggT = Replace[(Plus ## Times ### Join[#1, #2]
/. Plus -> List
/. Times[a_, b_] :> List[b, a]),
k_Symbol -> List[k, 1], {1}] &;
Using a couple of random symbolic tables I get
a := Tally#b;
b := Table[f[RandomInteger#99 + 1], {i, 100}];
Timing[Fold[aggT[#1, #2] &, a, Table[a, {i, 100}]];]
--> {0.104954, Null}
This version only adds tally lists, doesn't check anything, still returns some integers, and comparing to Leonid's function:
Timing[Fold[aggTallyAlt1[#2, #1] &, a, Table[b, {i, 100}]];]
--> {0.087039, Null}
it's already a couple of seconds slower :-(.
Oh well, nice try.