Good day,
I have some very slooooow and complicated function, say f[x,y]. And I need to construct detailed ContourPlot of it. Moreover the function f[x,y] sometimes fails due to lack of physical memory. In such cases I have to stop evaluation and investigate the problem case of the point {x,y} by myself. Then I should can add the element {x,y,f[x,y]} to a list of computed values of f[x,y] (say "cache") and restart evaluation of ContourPlot. ContourPlot must take all already computed values of f from the cache. I would prefer to store such list in some file for having ability to reuse it later. And it is probably simpler to add problematic points to this file by hand.
What is the fastest way to implement this if the list of computed values of f may contain 10000-50000 points?
Let's assume our slow function has the signature f[x, y].
Pure In-memory Approach
If you are satisfied with an in-memory cache, the simplest thing to do would be to use memoization:
Clear#fmem
fmem[x_, y_] := fmem[x, y] = f[x, y]
This adds a definition to itself every time it is called with a combination of arguments that it has not seen before.
File-backed In-memory Approach
However, if you are running out of memory or suffering kernel crashes during the long computation, you will want to back this cache with some kind of persistence. The simplest thing would be to keep a running log file:
$runningLogFile = "/some/directory/runningLog.txt";
Clear#flog
flog[x_, y_] := flog[x, y] = f[x, y] /.
v_ :> (PutAppend[Unevaluated[flog[x, y] = v;], $runningLogFile]; v)
If[FileExistsQ[$runningLogFile]
, Get[$runningLogFile]
, Export[$runningLogFile, "", "Text"];
]
flog is the same as fmem, except that it also writes an entry into the running log that can be used to restore the cached definition in a later session. The last expression reloads those definitions when it finds an existing log file (or creates the file if it does not exist).
The textual nature of the log file is convenient when manual intervention is required. Be aware that the textual representation of floating-point numbers introduces unavoidable round-off errors, so you may get slightly different results after reloading the values from the log file. If this is of great concern, you might consider using the binary DumpSave feature although I will leave the details of that approach to the reader as it is not quite as convenient for keeping an incremental log.
SQL Approach
If memory is really tight, and you want to avoid having a large in-memory cache to make room for the other computations, the previous strategy might not be appropriate. In that case, you might consider using Mathematica's built-in SQL database to store the cache completely externally:
fsql[x_, y_] :=
loadCachedValue[x, y] /. $Failed :> saveCachedValue[x, y, f[x, y]]
I define loadCachedValue and saveCachedValue below. The basic idea is to create an SQL table where each row holds an x, y, f triple. The SQL table is queried every time a value is needed. Note that this approach is substantially slower than the in-memory cache, so it makes the most sense when the computation of f takes much longer than the SQL access time. The SQL approach does not suffer from the round-off errors that afflicted the text log file approach.
The definitions of loadCachedValue and saveCachedValue now follow, along with some other useful helper functions:
Needs["DatabaseLink`"]
$cacheFile = "/some/directory/cache.hsqldb";
openCacheConnection[] :=
$cache = OpenSQLConnection[JDBC["HSQL(Standalone)", $cacheFile]]
closeCacheConnection[] :=
CloseSQLConnection[$cache]
createCache[] :=
SQLExecute[$cache,
"CREATE TABLE cached_values (x float, y float, f float)
ALTER TABLE cached_values ADD CONSTRAINT pk_cached_values PRIMARY KEY (x, y)"
]
saveCachedValue[x_, y_, value_] :=
( SQLExecute[$cache,
"INSERT INTO cached_values (x, y, f) VALUES (?, ?, ?)", {x, y, value}
]
; value
)
loadCachedValue[x_, y_] :=
SQLExecute[$cache,
"SELECT f FROM cached_values WHERE x = ? AND y = ?", {x, y}
] /. {{{v_}} :> v, {} :> $Failed}
replaceCachedValue[x_, y_, value_] :=
SQLExecute[$cache,
"UPDATE cached_values SET f = ? WHERE x = ? AND y = ?", {value, x, y}
]
clearCache[] :=
SQLExecute[$cache,
"DELETE FROM cached_values"
]
showCache[minX_, maxX_, minY_, maxY_] :=
SQLExecute[$cache,
"SELECT *
FROM cached_values
WHERE x BETWEEN ? AND ?
AND y BETWEEN ? AND ?
ORDER BY x, y"
, {minX, maxX, minY, maxY}
, "ShowColumnHeadings" -> True
] // TableForm
This SQL code uses floating point values as primary keys. This is normally a questionable practice in SQL but works fine in the present context.
You must call openCacheConnection[] before attempting to use any of these functions. You should call closeCacheConnection[] after you have finished. One time only, you must call createCache[] to initialize the SQL database. replaceCachedValue, clearCache and showCache are provided for manual interventions.
The simplest and possibly most efficient way to do this is just to set up the cached values as special case definitions for your function. The lookup is fairly fast due to hashing.
A function:
In[1]:= f[x_, y_] := Cos[x] + Cos[y]
Which points are used during a ContourPlot?
In[2]:= points = Last[
Last[Reap[
ContourPlot[f[x, y], {x, 0, 4 Pi}, {y, 0, 4 Pi},
EvaluationMonitor :> Sow[{x, y}]]]]];
In[3]:= Length[points]
Out[3]= 10417
Set up a version of f with precomputed values for 10000 of the evaluations:
In[4]:= Do[With[{x = First[p], y = Last[p]}, precomputedf[x, y] = f[x, y];], {p,
Take[points, 10000]}];
In the above, you would use something like precomputedf[x, y] = z instead of precomputed[x, y] = f[x, y], where z is your precomputed value that you have stored in your external file.
Here is the "else" case which just evaluates f:
In[5]:= precomputedf[x_, y_] := f[x, y]
Compare timings:
In[6]:= ContourPlot[f[x, y], {x, 0, 4 Pi}, {y, 0, 4 Pi}]; // Timing
Out[6]= {0.453539, Null}
In[7]:= ContourPlot[precomputedf[x, y], {x, 0, 4 Pi}, {y, 0, 4 Pi}]; // Timing
Out[7]= {0.440996, Null}
Not much difference in timing because in this example f is not an expensive function.
A separate remark for your particular application: Perhaps you could use ListContourPlot instead. Then you can choose exactly which points are evaluated.
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'm a bad cacher: Sometimes, when no one is watching, I'll cache results without including the full context like so:
f[x_]:=f[x]=x+a;
a=2; f[1];
DownValues[f]
Out[2]= {HoldPattern[f[1]]:>3,HoldPattern[f[x_]]:>(f[x]=x+a)}
This leads to horribly subtle bugs, and, more importantly, to the need for clearing the cache when I change the context. One way of clearing the cache is to completely Clear the symbol and repeat the definitions, but this is not really a solution.
What I would really like is a method for clearing all pattern-free DownValues associated with a symbol.
For clarity, I'll include my present solution as an answer, but if fails on two counts
It only clears DownValues with all-numeric arguments
For aesthetical reasons, I'd like to avoid using Block to grab the DownValues.
Any ideas on how to improve ClearCache?
I've made similar functions in the past (but I can't remember where).
Does the following code do all that you need?
ClearCache[f_] := DownValues[f] = DeleteCases[DownValues[f],
_?(FreeQ[First[#], Pattern] &)]
This maybe should be extended to UpValues and SubValues. And the Head of f restricted to Symbol.
Just to complement the other excellent solution: if you have a very large list of DownValues and have strict efficiency requirements for ClearCache, you can significantly speed up the process by clearing all definitions and then reconstructing only those with patterns. Here is an example:
In[1]:=
ClearCache[f_] :=
DownValues[f] = DeleteCases[DownValues[f], _?(FreeQ[First[#], Pattern] &)];
In[2]:= Clear[f];
f[x_] := f[x] = x;
In[4]:= f /# Range[1000000];
In[5]:= ClearCache[f]; // Timing
Out[5]= {7.765, Null}
In[6]:=
ClearAll[createDefs];
SetAttributes[createDefs, HoldRest];
createDefs[f_, defs_: Automatic] :=
(createDefs[f] := (Clear[f]; defs); createDefs[f]);
In[9]:= Clear[f];
createDefs[f, f[x_] := f[x] = x]
In[11]:= f /# Range[1000000];
In[12]:= Length[DownValues[f]]
Out[12]= 1000001
In[13]:= createDefs[f]; // Timing
Out[13]= {1.079, Null}
In[14]:= DownValues[f]
Out[14]= {HoldPattern[f[x_]] :> (f[x] = x)}
Note that you only have to call the createDefs once with the code that creates the pattern-based definitions of the function. All other times, you call it as createDefs[f], because it memoizes the code needed to re-create the definitions, on the first call.
It is also possible that you don't want to grow huge caches, but this is out of your control in the simple f[x_]:=f[x]=rhs approach. In other words, the cache may contain lots of unnecessary old stuff, but in this approach you can not tell old (no longer used) definitions from the new ones. I partially addressed this problem with a package I called Cache, which can be found here together with the notebook illustrating its use. It gives you more control over the size of the cache. It has its problems, but may occasionally be useful.
Once I implemented a scheme to limit the number of memoized values (and conserve memory). Search for memoization on that page. This might be useful here as well (especially considering some of the questions marked as duplicate of this one).
The code
SetAttributes[memo, HoldAll]
SetAttributes[memoStore, HoldFirst]
SetAttributes[memoVals, HoldFirst]
memoVals[_] = {};
memoStore[f_, x_] :=
With[{vals = memoVals[f]},
If[Length[vals] > 200,
f /: memoStore[f, First[vals]] =.;
memoVals[f] ^= Append[Rest[memoVals[f]], x],
memoVals[f] ^= Append[memoVals[f], x]];
f /: memoStore[f, x] = f[x]]
memo[f_Symbol][x_?NumericQ] := memoStore[f, x]
memoClearCache[f_Symbol] :=
(Scan[(f /: memoStore[f, #] =.) &, memoVals[f]];
f /: memoVals[f] =. )
Usage and description
This version works with functions that take a single numerical argument. Call memo[f][x] instead of f[x] to use a memoized version. Cached values are still associated with f, so when f is cleared, they are gone. The number of cached values is limited to 200 by default. Use memoClearCache[f] to clear all memoized values.
This is my present solution to the problem, but as mentioned in the question is doesn't strictly look for pattern-free DownValues, nor is it very elegant.
Store the DownValues for f
In[6]:= dv = DownValues[f]
Out[6]= {HoldPattern[f[1]] :> 3, HoldPattern[f[x_]] :> (f[x] = x + a)}
Find the DownValues to clear inside a Block to avoid immediate evaluation
In[7]:= dv2clear = Block[{f},
Hold#Evaluate#Cases[dv,
HoldPattern[f[args__ /; Apply[And, NumericQ /# Flatten[{args}]]]], {3}]]
Out[7]= Hold[{f[1]}]
Apply Unset to the targeted DownValues inside the held list and then release
In[8]:= Map[Unset, dv2clear, {2}]
ReleaseHold#%
Out[8]= Hold[{(f[1]) =.}]
This works fine
In[10]:= DownValues[f]
Out[10]= {HoldPattern[f[x_]] :> (f[x] = x + a)}
And can be wrapped up like so:
ClearCache[f_] := Module[{dv, dv2clear},
(* Cache downvalues for use inside block *)
dv = DownValues[f];
(* Find the downvalues to clear in Block to avoid immediate evaluation *)
dv2clear = Block[{f},Hold#Evaluate#Cases[dv,HoldPattern[
f[args__ /; Apply[And, NumericQ /# Flatten[{args}]]]], {3}]];
(* Apply Unset to the terms inside the held list and then release *)
ReleaseHold#Map[Unset, dv2clear, {2}];]
I am trying to get Mathematica to approximate an integral that is a function of various parameters. I don't need it to be extremely precise -- the answer will be a fraction, and 5 digits would be nice, but I'd settle for as few as 2.
The problem is that there is a symbolic integral buried in the main integral, and I can't use NIntegrate on it since its symbolic.
F[x_, c_] := (1 - (1 - x)^c)^c;
a[n_, c_, x_] := F[a[n - 1, c, x], c];
a[0, c_, x_] = x;
MyIntegral[n_,c_] :=
NIntegrate[Integrate[(D[a[n,c,y],y]*y)/(1-a[n,c,x]),{y,x,1}],{x,0,1}]
Mathematica starts hanging when n is greater than 2 and c is greater than 3 or so (generally as both n and c get a little higher).
Are there any tricks for rewriting this expression so that it can be evaluated more easily? I've played with different WorkingPrecision and AccuracyGoal and PrecisionGoal options on the outer NIntegrate, but none of that helps the inner integral, which is where the problem is. In fact, for the higher values of n and c, I can't even get Mathematica to expand the inner derivative, i.e.
Expand[D[a[4,6,y],y]]
hangs.
I am using Mathematica 8 for Students.
If anyone has any tips for how I can get M. to approximate this, I would appreciate it.
Since you only want a numerical output (or that's what you'll get anyway), you can convert the symbolic integration into a numerical one using just NIntegrate as follows:
Clear[a,myIntegral]
a[n_Integer?Positive, c_Integer?Positive, x_] :=
a[n, c, x] = (1 - (1 - a[n - 1, c, x])^c)^c;
a[0, c_Integer, x_] = x;
myIntegral[n_, c_] :=
NIntegrate[D[a[n, c, y], y]*y/(1 - a[n, c, x]), {x, 0, 1}, {y, x, 1},
WorkingPrecision -> 200, PrecisionGoal -> 5]
This is much faster than performing the integration symbolically. Here's a comparison:
yoda:
myIntegral[2,2]//Timing
Out[1]= {0.088441, 0.647376595...}
myIntegral[5,2]//Timing
Out[2]= {1.10486, 0.587502888...}
rcollyer:
MyIntegral[2,2]//Timing
Out[3]= {1.0029, 0.647376}
MyIntegral[5,2]//Timing
Out[4]= {27.1697, 0.587503006...}
(* Obtained with WorkingPrecision->500, PrecisionGoal->5, MaxRecursion->20 *)
Jand's function has timings similar to rcollyer's. Of course, as you increase n, you will have to increase your WorkingPrecision way higher than this, as you've experienced in your previous question. Since you said you only need about 5 digits of precision, I've explicitly set PrecisionGoal to 5. You can change this as per your needs.
To codify the comments, I'd try the following. First, to eliminate infinite recursion with regards to the variable, n, I'd rewrite your functions as
F[x_, c_] := (1 - (1-x)^c)^c;
(* see note below *)
a[n_Integer?Positive, c_, x_] := F[a[n - 1, c, x], c];
a[0, c_, x_] = x;
that way n==0 will actually be a stopping point. The ?Positive form is a PatternTest, and useful for applying additional conditions to the parameters. I suspect the issue is that NIntegrate is re-evaluating the inner Integrate for every value of x, so I'd pull that evaluation out, like
MyIntegral[n_,c_] :=
With[{ int = Integrate[(D[a[n,c,y],y]*y)/(1-a[n,c,x]),{y,x,1}] },
NIntegrate[int,{x,0,1}]
]
where With is one of several scoping constructs specifically for creating local constants.
Your comments indicate that the inner integral takes a long time, have you tried simplifying the integrand as it is a derivative of a times a function of a? It seems like the result of a chain rule expansion to me.
Note: as per Yoda's suggestion in the comments, you can add a cacheing, or memoization, mechanism to a. Change its definition to
d:a[n_Integer?Positive, c_, x_] := d = F[a[n - 1, c, x], c];
The trick here is that in d:a[ ... ], d is a named pattern that is used again in d = F[...] cacheing the value of a for those particular parameter values.
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.