Related
I aim to calculate and preserve the results from the maximization of a function with two arguments and one exogenous parameter, when the maximum can not be derived (in closed form) by maximize. For instance, let
f[x_,y_,a_]=Max[0,Min[a-y,1-x-y]
be the objective function where a is positive. The maximization shall take place over [0,1]^2, therefore I set
m[a_]=Maximize[{f[x, y, a], 0 <= x <= 1 && 0 <= y <= 1 && 0 <= a}, {x,y}]
Obviously m can be evaluated at any point a and it is therefore possible to plot the maximizing x by employing
Plot[x /. m[a][[2]], {a, 0.01, 1}]
As I need to do several plots and further derivations containing the optimal solutions x and y (which of course are functions of a), i would like to preserve/save the results from the optimization for further use. Is there an elegant way to do this, or do I have to write some kind of loop to extract the values myself?
Now that I've seen the full text of your comment on my original comment, I suspect that you do understand the differences between Set and SetDelayed well enough. I think what you may be looking for is memoisation, sometimes implemented a bit like this;
f[x_,y_] := f[x,y] = Max[0,Min[a-y,1-x-y]]
When you evaluate, for example f[3,4] for the first time it will evaluate to the entire expression to the right of the :=. The rhs is the assignment f[3,4] = Max[0,Min[a-y,1-x-y]]. Next time you evaluate f[3,4] Mathematica already has a value for it so doesn't need to recompute it, it just recalls it. In this example the stored value would be Max[0,Min[a-4,-6]] of course.
I remain a little uncertain of what you are trying to do so this answer may not be any use to you at all.
Simple approach
results = Table[{x, y, a} /. m[a][[2]], {a, 0.01, 1, .01}]
ListPlot[{#[[3]], #[[1]]} & /# results, Joined -> True]
(The Set = is ok here so long as 'a' is not previosly defined )
If you want to utilise Plot[]s automatic evaluation take a look at Reap[]/Sow[]
{p, data} = Reap[Plot[x /. Sow[m[a]][[2]], {a, 0.01, 1}]];
Show[p]
(this takes a few minutes as the function output is a mess..).
hmm try this again: assuming you want x,y,a and the minimum value:
{p, data} = Reap[Plot[x /. Sow[{a, m[a]}][[2, 2]], {a, 0.01, .1}]];
Show[p]
results = {#[[1]], x /. #[[2, 2]], y /. #[[2, 2]], #[[2, 1]]} & /# data[[1]]
BTW Your function appears to be independent of x over some ranges which is why the plot is a mess..
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}}
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.
Suppose I have a function f that takes a vector v and returns a new vector with the elements transformed in some way.
It does that by calling function g that assumes the vector is sorted.
So I want f to be defined like so:
f[v_] := Module[{s, r},
s = Sort[v]; (* remember the permutation applied in order to sort v *)
r = g[s];
Unsort[r] (* apply the inverse of that permutation *)
]
What's the best way to do the "Unsort"?
Or could we get really fancy and have this somehow work:
answer = Unsort[g[Sort[v]]];
ADDED: Let's make this concrete with a toy example.
Suppose we want a function f that takes a vector and transforms it by adding to each element the next smallest element, if any.
That's easy to write if we assume the vector is sorted, so let's write a helper function g that makes that assumption:
g[v_] := v + Prepend[Most#v, 0]
Now for the function we really want, f, that works whether or not v is sorted:
f[v_] := (* remember the order;
sort it;
call g on it;
put it back in the original order;
return it
*)
One possible method:
mylist = {c, 1, a, b, 2, 4, h, \[Pi]}
g /# (Sort#mylist)[[Ordering#Ordering#mylist]]
gives
{g[c], g1, g[a], g[b], g[2], g[4], g[h], g[[Pi]]}
That is,
(Sort#mylist)[[Ordering#Ordering#mylist]] == mylist
I originally learned of the above from MathGroup, [EDITED] from a post by Andrzej Kozlowski
http://forums.wolfram.com/mathgroup/archive/2007/Jun/msg00920.html
Here's a "sorting wrapper" pattern suggested by Michael Pilat earlier
Clear[g];
g[a_] := If[OrderedQ[a], a^2, Print["Failed"]];
g[{3, 2, 1}]
g[a_] := g[Sort#a][[Ordering#Ordering#a]] /; Not[OrderedQ[a]];
g[{3, 2, 1}]
Thanks to TomD and Yaroslav, here's probably the most concise/elegant way to do it:
f[v_] := g[Sort#v][[Ordering#Ordering#v]]
And thanks to Janus, here's a perhaps more efficient way:
f[v_] := With[{o = Ordering#v}, g[v[[o]]][[Ordering#o]]]
Note that it does 2 sorts instead of 3.
For posterity, here's my original attempt, though I don't think it has anything to recommend it over the above:
f[v_] := With[{o = Ordering[v]}, Sort[Transpose[{o,g[v[[o]]]}]][[All,-1]]]
To address belisarius in the comments, the reason I'm not passing g as a parameter is because I'm thinking of g as a helper function for f.
It's like I have a function f that would be easier to write if I could assume its argument was a sorted vector.
So I write the version that assumes that and then do this wrapper trick.