I often have a list of pairs, as
data = {{0,0.0},{1,12.4},{2,14.6},{3,25.1}}
and I want to do something, for instance Rescale, to all of the second elements without touching the first elements. The neatest way I know is:
Transpose[MapAt[Rescale, Transpose[data], 2]]
There must be a way to do this without so much Transposeing. My wish is for something like this to work:
MapAt[Rescale, data, {All, 2}]
But my understanding is that MapAt takes Position-style specifications instead of Part-style specifications. What's the proper solution?
To clarify,
I'm seeking a solution where I don't have to repeat myself, so lacking double Transpose or double [[All,2]], because I consider repetition a signal I'm not doing something the easiest way. However, if eliminating the repetition requires the introduction of intermediate variables or a named function or other additional complexity, maybe the transpose/untranspose solution is already correct.
Use Part:
data = {{0, 0.0}, {1, 12.4}, {2, 14.6}, {3, 25.1}}
data[[All, 2]] = Rescale # data[[All, 2]];
data
Create a copy first if you need to. (data2 = data then data2[[All, 2]] etc.)
Amending my answer to keep up with ruebenko's, this can be made into a function also:
partReplace[dat_, func_, spec__] :=
Module[{a = dat},
a[[spec]] = func # a[[spec]];
a
]
partReplace[data, Rescale, All, 2]
This is quite general is design.
I am coming late to the party, and what I will describe will differ very little with what #Mr. Wizard has, so it is best to consider this answer as a complementary to his solution. My partial excuses are that first, the function below packages things a bit differently and closer to the syntax of MapAt itself, second, it is a bit more general and has an option to use with Listable function, and third, I am reproducing my solution from the past Mathgroup thread for exactly this question, which is more than 2 years old, so I am not plagiarizing :)
So, here is the function:
ClearAll[mapAt,MappedListable];
Protect[MappedListable];
Options[mapAt] = {MappedListable -> False};
mapAt[f_, expr_, {pseq : (All | _Integer) ..}, OptionsPattern[]] :=
Module[{copy = expr},
copy[[pseq]] =
If[TrueQ[OptionValue[MappedListable]] && Head[expr] === List,
f[copy[[pseq]]],
f /# copy[[pseq]]
];
copy];
mapAt[f_, expr_, poslist_List] := MapAt[f, expr, poslist];
This is the same idea as what #Mr. Wizard used, with these differences: 1. In case when the spec is not of the prescribed form, regular MapAt will be used automatically 2. Not all functions are Listable. The solution of #Mr.Wizard assumes that either a function is Listable or we want to apply it to the entire list. In the above code, you can specify this by the MappedListable option.
I will also borrow a few examples from my answer in the above-mentioned thread:
In[18]:= mat=ConstantArray[1,{5,3}];
In[19]:= mapAt[#/10&,mat,{All,3}]
Out[19]= {{1,1,1/10},{1,1,1/10},{1,1,1/10},{1,1,1/10},{1,1,1/10}}
In[20]:= mapAt[#/10&,mat,{3,All}]
Out[20]= {{1,1,1},{1,1,1},{1/10,1/10,1/10},{1,1,1},{1,1,1}}
Testing on large lists shows that using Listability improves the performance, although not so dramatically here:
In[28]:= largemat=ConstantArray[1,{150000,15}];
In[29]:= mapAt[#/10&,largemat,{All,3}];//Timing
Out[29]= {0.203,Null}
In[30]:= mapAt[#/10&,largemat,{All,3},MappedListable->True];//Timing
Out[30]= {0.094,Null}
This is likely because for the above function (#/10&), Map (which is used internally in mapAt for the MappedListable->False (default) setting, was able to auto-compile. In the example below, the difference is more substantial:
ClearAll[f];
f[x_] := 2 x - 1;
In[54]:= mapAt[f,largemat,{All,3}];//Timing
Out[54]= {0.219,Null}
In[55]:= mapAt[f,largemat,{All,3},MappedListable->True];//Timing
Out[55]= {0.031,Null}
The point is that, while f was not declared Listable, we know that its body is built out of Listable functions, and thus it can be applied to the entire list - but OTOH it can not be auto-compiled by Map. Note that adding Listable attribute to f would have been completely wrong here and would destroy the purpose, leading to mapAt being slow in both cases.
How about
Transpose[{#[[All, 1]], Rescale[#[[All, 2]]]} &#data]
which returns what you want (ie, it does not alter data)
If no Transpose is allowed,
Thread[Join[{#[[All, 1]], Rescale[#[[All, 2]]]} &#data]]
works.
EDIT: As "shortest" is now the goal, best from me so far is:
data\[LeftDoubleBracket]All, 2\[RightDoubleBracket] = Rescale[data[[All, 2]]]
at 80 characters, which is identical to Mr.Wizard's... So vote for his answer.
Here is another approach:
op[data_List, fun_] :=
Join[data[[All, {1}]], fun[data[[All, {2}]]], 2]
op[data, Rescale]
Edit 1:
An extension from Mr.Wizard, that does not copy it's data.
SetAttributes[partReplace, HoldFirst]
partReplace[dat_, func_, spec__] := dat[[spec]] = func[dat[[spec]]];
used like this
partReplace[data, Rescale, All, 2]
Edit 2:
Or like this
ReplacePart[data, {All, 2} -> Rescale[data[[All, 2]]]]
This worked for me and a friend
In[128]:= m = {{x, sss, x}, {y, sss, y}}
Out[128]= {{2, sss, 2}, {y, sss, y}}
In[129]:= function[ins1_] := ToUpperCase[ins1];
fatmap[ins2_] := MapAt[function, ins2, 2];
In[131]:= Map[fatmap, m]
Out[131]= {{2, ToUpperCase[sss], 2}, {y, ToUpperCase[sss], y}}
Related
I can't seem to understand the difference between the behaviour of Plot and PlotLog (and other log-scale plotting functions) in Mathematica. Let's say I have this simple function:
f [a_] := Length[Range[0, a]]
now running Plot[f[x], {x, 1, 10}] yields a correct graph, but when I try
PlotLog[f[x], {x, 1, 10}]
I get no output save the following error:
Range::range: "Range specification in Range[1,x] does not have appropriate bounds."
Looks like the evaluation of x is postponed which makes it impossible to create a list from Range, but why on Earth would it happen to log-scale plotting functions only and how do I handle this issue?
PlotLog doesn't exists. If you use LogPlot it will work correctly.
In any case, you may have problems with that definition. I would recommend to define f like f2[a_Real] := Length[Range[0, a]] or f3[a_?NumericQ] := Length[Range[0, a]]so only numbers will be passed to Range.
For example, with your definition, this will fail:
NIntegrate[f[x], {x, 1, 10}]
During evaluation of In[43]:= Range::range: Range specification in Range[0,x] does not have appropriate bounds. >>
18.
But defining a as NumericQ or Real, it will work.
NIntegrate[f2[x],{x,1,10}]
54.
Regards.
Some types of objects have special input/output formatting in Mathematica. This includes Graphics, raster images, and, as of Mathematica 8, graphs (Graph[]). Unfortunately large graphs may take a very long time to visualize, much longer than most other operations I'm doing on them during interactive work.
How can I prevent auto-layout of Graph[] objects in StandardForm and TraditionalForm, and have them displayed as e.g. -Graph-, preferably preserving the interpretability of the output (perhaps using Interpretation?). I think this will involve changing Format and/or MakeBoxes in some way, but I was unsuccessful in getting this to work.
I would like to do this in a reversible way, and preferably define a function that will return the original interactive graph display when applied to a Graph object (not the same as GraphPlot, which is not interactive).
On a related note, is there a way to retrieve Format/MakeBoxes definitions associated with certain symbols? FormatValues is one relevant function, but it is empty for Graph.
Sample session:
In[1]:= Graph[{1->2, 2->3, 3->1}]
Out[1]= -Graph-
In[2]:= interactiveGraphPlot[%] (* note that % works *)
Out[2]= (the usual interactive graph plot should be shown here)
Though I do not have Mathematica 8 to try this in, one possibility is to use this construct:
Unprotect[Graph]
MakeBoxes[g_Graph, StandardForm] /; TrueQ[$short] ^:=
ToBoxes#Interpretation[Skeleton["Graph"], g]
$short = True;
Afterward, a Graph object should display in Skeleton form, and setting $short = False should restore default behavior.
Hopefully this works to automate the switching:
interactiveGraphPlot[g_Graph] := Block[{$short}, Print[g]]
Mark's concern about modifying Graph caused me to consider the option of using $PrePrint. I think this should also prevent the slow layout step from taking place. It may be more desirable, assuming you are not already using $PrePrint for something else.
$PrePrint =
If[TrueQ[$short], # /. _Graph -> Skeleton["Graph"], #] &;
$short = True
Also conveniently, at least with Graphics (again I cannot test with Graph in v7) you can get the graphic with simply Print. Here, shown with Graphics:
g = Plot[Sin[x], {x, 0, 2 Pi}]
(* Out = <<"Graphics">> *)
Then
Print[g]
I left the $short test in place for easy switching via a global symbol, but one could leave it out and use:
$PrePrint = # /. _Graph -> Skeleton["Graph"] &;
And then use $PrePrint = . to reset the default functionality.
You can use GraphLayout option of Graph as well as graph-constructors to suppress the rendering. A graph can still be visualized with GraphPlot. Try the following
{gr1, gr2, gr3} = {RandomGraph[{100, 120}, GraphLayout -> None],
PetersenGraph[10, 3, GraphLayout -> None],
Graph[{1 -> 2, 2 -> 3, 3 -> 1}, GraphLayout -> None]}
In order to make working easier, you can use SetOptions to set GraphLayout option to None for all graph constructors you are interested in.
Have you tried simply suppressing the output? I don't think that V8's Graph command does any layout, if you do so. To explore this, we can generate a large list of edges and compare the timings of graph[edges];, Graph[edges];, and GraphPlot[edges];
In[23]:= SeedRandom[1];
edges = Union[Rule ### (Sort /#
RandomInteger[{1, 5000}, {50000, 2}])];
In[25]:= t = AbsoluteTime[];
graph[edges];
In[27]:= AbsoluteTime[] - t
Out[27]= 0.029354
In[28]:= t = AbsoluteTime[];
Graph[edges];
In[30]:= AbsoluteTime[] - t
Out[30]= 0.080434
In[31]:= t = AbsoluteTime[];
GraphPlot[edges];
In[33]:= AbsoluteTime[] - t
Out[33]= 4.934918
The inert graph command is, of course, the fastest. The Graph command takes much longer, but no where near as long as the GraphPlot command. Thus, it seems to me that Graph is not, in fact, computing the layout, as GraphPlot does.
The logical question is, what is Graph spending it's time on. Let's examine the InputForm of Graph output in a simple case:
Graph[{1 -> 2, 2 -> 3, 3 -> 1, 1 -> 4}] // InputForm
Out[123]//InputForm=
Graph[{1, 2, 3, 4},
{DirectedEdge[1, 2],
DirectedEdge[2, 3],
DirectedEdge[3, 1],
DirectedEdge[1, 4]}]
Note that the vertices of the graph have been determined and I think this is what Graph is doing. In fact, the amount of time it took to compute Graph[edges] in the first example, comparable to the fastest way that I can think to do this:
Union[Sequence ### edges]; // Timing
This took 0.087045 seconds.
Suppose I write a black-box functions, which evaluates an expensive complex valued function numerically, and then returns real and imaginary part.
fun[x_?InexactNumberQ] := Module[{f = Sin[x]}, {Re[f], Im[f]}]
Then I can use it in Plot as usual, but Plot does not recognize that the function returns a pair, and colors both curves the same color. How does one tell Mathematica that the function specified always returns a vector of a fixed length ? Or how does one style this plot ?
EDIT: Given attempts attempted at answering the problem, I think that avoiding double reevalution is only possible if styling is performed as a post-processing of the graphics obtained. Most likely the following is not robust, but it seems to work for my example:
gr = Plot[fun[x + I], {x, -1, 1}, ImageSize -> 250];
k = 1;
{gr, gr /. {el_Line :> {ColorData[1][k++], el}}}
One possibility is:
Plot[{#[[1]], #[[2]]}, {x, -1, 1}, PlotStyle -> {{Red}, {Blue}}] &# fun[x + I]
Edit
If your functions are not really smooth (ie. almost linear!), there is not much you can do to prevent the double evaluation process, as it will happen (sort of) anyway due to the nature of the Plot[] mesh exploration algorithm.
For example:
fun[x_?InexactNumberQ] := Module[{f = Sin[3 x]}, {Re[f], Im[f]}];
Plot[{#[[1]], #[[2]]}, {x, -1, 1}, Mesh -> All,
PlotStyle -> {{Red}, {Blue}}] &#fun[x + I]
I don't think there's a good solution to this if your function is expensive to compute. Plot will only acknowledge that there are several curves to be styled if you either give it an explicit list of functions as argument, or you give it a function that it can evaluate to a list of values.
The reason you might not want to do what #belisarius suggested is that it would compute the function twice (twice as slow).
However, you could use memoization to avoid this (i.e. the f[x_] := f[x] = ... construct), and go with his solution. But this can fill up your memory quickly if you work with real valued functions. To prevent this you may want to try what I wrote about caching only a limited number of values, to avoid filling up the memory: http://szhorvat.net/pelican/memoization-in-mathematica.html
If possible for your actual application, one way is to allow fun to take symbolic input in addition to just numeric, and then Evaluate it inside of Plot:
fun2[x_] := Module[{f = Sin[x]}, {Re[f], Im[f]}]
Plot[Evaluate[fun2[x + I]], {x, -1, 1}]
This has the same effect as if you had instead evaluated:
Plot[{-Im[Sinh[1 - I x]], Re[Sinh[1 - I x]]}, {x, -1, 1}]
What is the simplest way to map an arbitrarily funky nested list expr to a function unflatten so that expr==unflatten##Flatten#expr?
Motivation:
Compile can only handle full arrays (something I just learned -- but not from the error message), so the idea is to use unflatten together with a compiled version of the flattened expression:
fPrivate=Compile[{x,y},Evaluate#Flatten#expr];
f[x_?NumericQ,y_?NumericQ]:=unflatten##fPrivate[x,y]
Example of a solution to a less general problem:
What I actually need to do is to calculate all the derivatives for a given multivariate function up to some order. For this case, I hack my way along like so:
expr=Table[D[x^2 y+y^3,{{x,y},k}],{k,0,2}];
unflatten=Module[{f,x,y,a,b,sslot,tt},
tt=Table[D[f[x,y],{{x,y},k}],{k,0,2}] /.
{Derivative[a_,b_][_][__]-> x[a,b], f[__]-> x[0,0]};
(Evaluate[tt/.MapIndexed[#1->sslot[#2[[1]]]&,
Flatten[tt]]/. sslot-> Slot]&) ]
Out[1]= {x^2 y + y^3, {2 x y, x^2 + 3 y^2}, {{2 y, 2 x}, {2 x, 6 y}}}
Out[2]= {#1, {#2, #3}, {{#4, #5}, {#5, #7}}} &
This works, but it is neither elegant nor general.
Edit: Here is the "job security" version of the solution provided by aaz:
makeUnflatten[expr_List]:=Module[{i=1},
Function#Evaluate#ReplaceAll[
If[ListQ[#1],Map[#0,#1],i++]&#expr,
i_Integer-> Slot[i]]]
It works a charm:
In[2]= makeUnflatten[expr]
Out[2]= {#1,{#2,#3},{{#4,#5},{#6,#7}}}&
You obviously need to save some information about list structure, because Flatten[{a,{b,c}}]==Flatten[{{a,b},c}].
If ArrayQ[expr], then the list structure is given by Dimensions[expr] and you can reconstruct it with Partition. E.g.
expr = {{a, b, c}, {d, e, f}};
dimensions = Dimensions[expr]
{2,3}
unflatten = Fold[Partition, #1, Reverse[Drop[dimensions, 1]]]&;
expr == unflatten # Flatten[expr]
(The Partition man page actually has a similar example called unflatten.)
If expr is not an array, you can try this:
expr = {a, {b, c}};
indexes = Module[{i=0}, If[ListQ[#1], Map[#0, #1], ++i]& #expr]
{1, {2, 3}}
slots = indexes /. {i_Integer -> Slot[i]}
{#1, {#2, #3}}
unflatten = Function[Release[slots]]
{#1, {#2, #3}} &
expr == unflatten ## Flatten[expr]
I am not sure what you are trying to do with Compile. It is used when you want to evaluate procedural or functional expressions very quickly on numerical values, so I don't think it is going to help here. If repeated calculations of D[f,...] are impeding your performance, you can precompute and store them with something like
Table[d[k]=D[f,{{x,y},k}],{k,0,kk}];
Then just call d[k] to get the kth derivative.
I just wanted to update the excellent solutions by aaz and Janus. It seems that, at least in Mathematica 9.0.1.0 on Mac OSX, the assignment (see aaz's solution)
{i_Integer -> Slot[i]}
fails. If, however, we use
{i_Integer :> Slot[i]}
instead, we succeed. The same holds, of course, for the ReplaceAll call in Janus's "job security" version.
For good measure, I include my own function.
unflatten[ex_List, exOriginal_List] :=
Module[
{indexes, slots, unflat},
indexes =
Module[
{i = 0},
If[ListQ[#1], Map[#0, #1], ++i] &#exOriginal
];
slots = indexes /. {i_Integer :> Slot[i]};
unflat = Function[Release[slots]];
unflat ## ex
];
(* example *)
expr = {a, {b, c}};
expr // Flatten // unflatten[#, expr] &
It might seem a little like a cheat to use the original expression in the function, but as aaz points out, we need some information from the original expression. While you don't need it all, in order to have a single function that can unflatten, all is necessary.
My application is similar to Janus's: I am parallelizing calls to Simplify for a tensor. Using ParallelTable I can significantly improve performance, but I wreck the tensor structure in the process. This gives me a quick way to reconstruct my original tensor, simplified.
I have a large set of parameters P which take several distinct sets of values V_i and want to use ActionMenu[] to make assigning P=V_i easy, like so:
ActionMenu["Label", {"name_1" :> (P = V_1;),..}]
Now the problem is that the set of V_i's is large and not static, so instead of coding a long list {"opt_1" :> (P = V_1;),..} over and over by hand, I'd like to generate it.
I am completely stumped at how to do it. The general approach is something like
Thread#RuleDelayed[listOfNames,listOfActions]
where listOfActions should be something like
Thread#Set[repeatedListOfP,listOfV_i]
But this does not work. And since Set[] is a very special function, none of my other usual approaches work (building a Table[], replacing headers, etc). How do you go about constructing a list of Set[] operations?
There may be more to your question that I haven't grokked yet but maybe this will get you on the right track.
This
MapThread[Hold[#1 = #2]&, {{a, b, c}, {1, 2, 3}}]
returns a list of unevaluated "Set"s like so:
{Hold[a = 1], Hold[b = 2], Hold[c = 3]}
If you call ReleaseHold on the above then the assignments will actually happen.
More on Hold and relatives here:
Mathematica: Unevaluated vs Defer vs Hold vs HoldForm vs HoldAllComplete vs etc etc
Here's an alternative solution that I've used when I've wanted to have RuleDelayed applications that have side-effects. You use a different head to substitute in for Set until you have your expression on the right-hand side of a RuleDelayed form (where it'll be held by RuleDelayed's HoldRest attribute) and then subsitute Set back in. When I do this, I like to use Module to create a unique symbol for me. This way you don't have to use Defer, which is an even more unpleasantly slippery construct than Unevaluated.
Here's an example:
Module[{set},
Attributes[set] = Attributes[Set];
With[{rhs = MapThread[set, Unevaluated[{{x, y, z}, {1, 2, 3}}]]},
"name1" :> rhs /. {set -> Set, List -> CompoundExpression}]]
The reason the set symbol is given the same attributes as Set, and the reason the Unevaluated is there, is to make sure this works even if someone has already assigned a value to x, y or z.
Another possibility is to wrap all your Set expressions up as closures and then use Scan to call them when the RuleDelayed is evaluated, like so:
With[{thunks = MapThread[Function[{a, b}, (a = b) &, HoldAll],
Unevaluated[{{x, y, z}, {1, 2, 3}}]]},
"name1" :> Scan[#[] &, thunks]]