Poisson Solver using Mathematica - wolfram-mathematica

I am looking for some help with a Poisson Solver I am writing in Mathematica. The code is quite long with Arrays plugged in, but the full details can be found at http://pastebin.com/uSrSDcW6
I am calculating voltages given charge densities using the central difference method derived from Poisson's Eqn. After calculating the voltage, I test the data set for convergence. I am setting convergence thresholds on the order of 10^-1000+. I have the loop set up to kick out after 10000 iterations incase something goes awry, as a fail safe. I have a loop counter in place for sanity. The program seems to run fine as long as the convergence threshold is set to 10^-100.
My question is this: No matter what I update the threshold too, ex, 10^-100, 10^-150, the computation stops after 633 iterations and kicks out of the loop. I would appreciate any help with this, I am completely stuck. I've added comments to the program that should be explanatory for anyone on this forum. Again, I know this description is limited, so please see the attached url http://pastebin.com/uSrSDcW6 for the full program.
*Update10/9/12***I've isolated my issue down to the 16 digit machine precision. I need to open that up to my machine max precision of 10^309. Mathematica Help is sparse on how to do this. ex "N[MachinePrecision, 50]". Where would I set this in my program to apply it to all computation? Ill paste the loop here if that helps
Vnew / Vold / RHO are 10x10x34 Matrices
Epsilon is a constant
(Initialize ConvergenceLoop to O - This will serve as a fail safe to kick out of the loop if necessary)
ConvergenceLoop = 0;
(Initialize Convergence to zero)
Convergence = 0;
While[Convergence == 0 && ConvergenceLoop < 10000,
(Run through all i,j,k elements,calculating new voltage values)
Do[Vnew[[i]][[j]][[k]] = (1/(2/deltaX^2 + 2/deltaY^2 +
2/deltaZ^2)) *(((Vold[[i + 1]][[j]][[k]] +
Vold[[i - 1]][[j]][[k]])/(deltaX^2)) + ((Vold[[i]][[j + 1]][[k]] +
Vold[[i]][[j - 1]][[k]])/(deltaY^2)) + ((Vold[[i]][[j]][[k + 1]] +
Vold[[i]][[j]][[k - 1]])/(deltaZ^2)) + ((Rho[[i]][[j]][[k]]/Epsilon))), {i, 2, 9}, {j, 2,9}, {k, 2, 33}];
(Assume converged so the loop is triggered when the test hits the first value exceeding the defined convergence threshold)
Convergence = 1;
(This is the convergence test. User defined Convergence threshold)
Do[If[Vold[[i]][[j]][[k]] == 0, Null,
If[(Vnew[[i]][[j]][[k]] - Vold[[i]][[j]][[k]])/Vold[[i]][[j]][[k]] > .0000001, Convergence = 0;
(*This is purely diagnostic. I added a Tracker point to follow the convergence along.
user defined at any element*)
If[i == 5 && j == 5 && k == 10,
Print[ "Tracker Point" (Vnew[[i]][[j]][[k]] -
Vold[[i]][[j]][[k]])/Vold[[i]][[j]][[k]]], Null],Null]], {i, 2, 9}, {j, 2, 9}, {k, 2, 33}];
(Ignore the first iteration until Vnew and Vold are nonzero)
If[ConvergenceLoop < 2, Convergence = 0, Null];
(Forces Vold to evolve with Vnew)
Vold = Vnew;
ConvergenceLoop ++;]
(Added SessionTime for future planning purposes)
If[ConvergenceLoop == 10000,
Print["Convergence Loop Limit Reached. " (SessionTime[]/3600) ],
Print["Convergence Loop Limit Not Reached."]];
(We broke out of the while loop,meaning our data converged,so print the converged values)
If[Convergence == 1,
Print[ ConvergenceLoop "Congratulations Converged!" MatrixForm [Vnew]], Print["Did Not Converge!"]];

Since based on the comments above you have narrowed this to a precision problem as I suspected, please read these:
Funny behaviour when plotting a polynomial of high degree and large coefficients
Global precision setting
Confused by (apparent) inconsistent precision

Related

Wolfram Mathematica Solve command for a nonlinear system of equations

I am trying to solve a nonlinear system of equations by using the Solve (and NSolve) command, but the evaluation get stuck.
For a very similar system, basically the same but with the derivatives of the equations I get no problems. I define the functions I need, write the equations, define the variables, define the solutions through the Solve command, and, once obtained with another system the initial values, I try to solve the system with NSolve.
Defining the functions:
a[x_] := A (1 - ms[x])
b[x_]:=2 ((ArcSinh[nn[x]/ms[x]] ms[x]^3 + nn[x] ms[x] Sqrt[nn[x]^2 + ms[x]^2])/(8 \[Pi]^2) + (ArcSinh[pp[x]/ms[x]] ms[x]^3 + pp[x] ms[x] Sqrt[pp[x]^2 + ms[x]^2])/(8 \[Pi]^2))
where A is a constant. Here I deleted some multiplicative constants to simplify the problem.
Then I have the equations:
eq1[x_]:= B a[x] + C a[x]^2 + D a[x]^3 - F b[x]
eq2[x_]:= pp[x]^3 - nn[x]^3
eq3[x_]:= G - (pp[x]^3 + nn[x]^3)
eq4[x_]:= Sqrt[nn[x]^2 + ms[x]^2] - Sqrt[pp[x]^2 + ms[x]^2] - Sqrt[m + ee[x]^2] + H (pp[x]^3 - nn[x]^3)
where B, C, D, G, m and H are constants. Here too, I deleted some multiplicative constants, to simplify the code for you.
Finally, I define the variables:
Var = {ee[x], pp[x], nn[x], ms[x]}
then solve the system "implicitly":
Sol =
Solve[{eq1[x] == 0, eq2[x] == 0, eq3[x] == 0, eq4[x] == 0}, Var]
(N.B: it is here that the code get stuck!!!! Despite, as I said, with a similar system with derivatives of the equations, everything work fine.)
and make a list of the equations:
eqs =
Table[Var[[i]] == (Var[[i]] /. Sol[[1]]), {i, Length[Var]}];
To conclude, after having obtained the initial conditions, I would try to solve the system:
system0 = Flatten[{eqs, ee[xi] == eei, pp[xi] == ppi, nn[xi] == nni, ms[xi] == msi}];
sol0 = NSolve[system0, {ee, kpp, nn, ms}, {x, xi, xf}, Flatten[{MaxSteps -> 10^4, MaxStepFraction -> 10^-2, WorkingPrecision -> 30, InterpolationOrder -> All}, 1]];
where I previously set xi = 10^-8 and xf = 10.
Trying to be more clear, when I try to evaluate the system through the Solve command, the evaluation continues indefinitely and I cannot understand why, where is the mistake. Despite a similar system with the derivative of the previous equations and NSolve replaced with NDSolve, works without any problem, and the execution of the "equivalent" line (Sol = Solve[{eq1[x] == 0, eq2[x] == 0, eq3[x] == 0, eq4[x] == 0}, Core]) is extremely fast (~1 sec).
Any help to understand where I am wrong is welcome, as well any suggestion to solve numerically this kind of system of equations.
Trying to be more clear, when I try to evaluate the system through the Solve command, the evaluation continues indefinitely and I cannot understand why, where is the mistake. Despite a similar system with the derivative of the previous equations and NSolve replaced with NDSolve, works without any problem, and the execution of the "equivalent" line (Sol = Solve[{eq1[x] == 0, eq2[x] == 0, eq3[x] == 0, eq4[x] == 0}, Core]) is extremely fast (~1 sec).
Any help to understand where I am wrong is welcome, as well any suggestion to solve numerically this kind of system of equations.

Dynamic Programming and Probability

I've been staring at this problem for hours and I'm still as lost as I was at the beginning. It's been a while since I took discrete math or statistics so I tried watching some videos on youtube, but I couldn't find anything that would help me solve the problem in less than what seems to be exponential time. Any tips on how to approach the problem below would be very much appreciated!
A certain species of fern thrives in lush rainy regions, where it typically rains almost every day.
However, a drought is expected over the next n days, and a team of botanists is concerned about
the survival of the species through the drought. Specifically, the team is convinced of the following
hypothesis: the fern population will survive if and only if it rains on at least n/2 days during the
n-day drought. In other words, for the species to survive there must be at least as many rainy days
as non-rainy days.
Local weather experts predict that the probability that it rains on a day i ∈ {1, . . . , n} is
pi ∈ [0, 1], and that these n random events are independent. Assuming both the botanists and
weather experts are correct, show how to compute the probability that the ferns survive the drought.
Your algorithm should run in time O(n2).
Have an (n + 1)×n matrix such that C[i][j] denotes the probability that after ith day there will have been j rainy days (i runs from 1 to n, j runs from 0 to n). Initialize:
C[1][0] = 1 - p[1]
C[1][1] = p[1]
C[1][j] = 0 for j > 1
Now loop over the days and set the values of the matrix like this:
C[i][0] = (1 - p[i]) * C[i-1][0]
C[i][j] = (1 - p[i]) * C[i-1][j] + p[i] * C[i - 1][j - 1] for j > 0
Finally, sum the values from C[n][n/2] to C[n][n] to get the probability of fern survival.
Dynamic programming problems can be solved in a top down or bottom up fashion.
You've already had the bottom up version described. To do the top-down version, write a recursive function, then add a caching layer so you don't recompute any results that you already computed. In pseudo-code:
cache = {}
function whatever(args)
if args not in cache
compute result
cache[args] = result
return cache[args]
This process is called "memoization" and many languages have ways of automatically memoizing things.
Here is a Python implementation of this specific example:
def prob_survival(daily_probabilities):
days = len(daily_probabilities)
days_needed = days / 2
# An inner function to do the calculation.
cached_odds = {}
def prob_survival(day, rained):
if days_needed <= rained:
return 1.0
elif days <= day:
return 0.0
elif (day, rained) not in cached_odds:
p = daily_probabilities[day]
p_a = p * prob_survival(day+1, rained+1)
p_b = (1- p) * prob_survival(day+1, rained)
cached_odds[(day, rained)] = p_a + p_b
return cached_odds[(day, rained)]
return prob_survival(0, 0)
And then you would call it as follows:
print(prob_survival([0.2, 0.4, 0.6, 0.8])

Is there a faster way to find both Min and Max values?

Often I have written: {Min##, Max##} &
Yet this seems inefficient, as the expression must be scanned twice, once to find the minimum value, and once to find the maximum value. Is there a faster way to do this? The expression is often a tensor or array.
This beats it by a bit.
minMax = Compile[{{list, _Integer, 1}},
Module[{currentMin, currentMax},
currentMin = currentMax = First[list];
Do[
Which[
x < currentMin, currentMin = x,
x > currentMax, currentMax = x],
{x, list}];
{currentMin, currentMax}],
CompilationTarget -> "C",
RuntimeOptions -> "Speed"];
v = RandomInteger[{0, 1000000000}, {10000000}];
minMax[v] // Timing
I think it's a little faster than Leonid's version because Do is a bit faster than For, even in compiled code.
Ultimately, though, this is an example of the kind of performance hit you take when using a high level, functional programming language.
Addition in response to Leonid:
I don't think that the algorithm can account for all the time difference. Much more often than not, I think, both tests will be applied anyway. The difference between Do and For is measurable, however.
cf1 = Compile[{{list, _Real, 1}},
Module[{sum},
sum = 0.0;
Do[sum = sum + list[[i]]^2,
{i, Length[list]}];
sum]];
cf2 = Compile[{{list, _Real, 1}},
Module[{sum, i},
sum = 0.0;
For[i = 1, i <= Length[list],
i = i + 1, sum = sum + list[[i]]^2];
sum]];
v = RandomReal[{0, 1}, {10000000}];
First /#{Timing[cf1[v]], Timing[cf2[v]]}
{0.685562, 0.898232}
I think this is as fast as it gets, within Mathematica programming practices. The only way I see to attempt to make it faster within mma is to use Compile with the C compilation target, as follows:
getMinMax =
Compile[{{lst, _Real, 1}},
Module[{i = 1, min = 0., max = 0.},
For[i = 1, i <= Length[lst], i++,
If[min > lst[[i]], min = lst[[i]]];
If[max < lst[[i]], max = lst[[i]]];];
{min, max}], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
However, even this seems to be somewhat slower than your code:
In[61]:= tst = RandomReal[{-10^7,10^7},10^6];
In[62]:= Do[getMinMax[tst],{100}]//Timing
Out[62]= {0.547,Null}
In[63]:= Do[{Min##,Max##}&[tst],{100}]//Timing
Out[63]= {0.484,Null}
You probably can write the function entirely in C, and then compile and load as dll - you may eliminate some overhead this way, but I doubt that you will win more than a few percents - not worth the effort IMO.
EDIT
It is interesting that you may significantly increase the speed of the compiled solution with manual common subexpression elimination (lst[[i]] here):
getMinMax =
Compile[{{lst, _Real, 1}},
Module[{i = 1, min = 0., max = 0., temp},
While[i <= Length[lst],
temp = lst[[i++]];
If[min > temp, min = temp];
If[max < temp, max = temp];];
{min, max}], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
is a little faster than {Min##,Max##}.
For an array, you could do the simplest functional thing and use
Fold[{Min[##],Max[##]}&, First##, Rest##]& # data
Unfortunately, it is no speed demon. Even for short lists, 5 elements, all of Leonid's answers and Mark's answer are at least 7 times faster, uncompiled in v.7. For long lists, 25000 elements, this gets worse with Mark's being 19.6 times faster, yet even at this length this solution took only about 0.05 secs to run.
However, I'd not count out {Min[#], Max[#]}& as an option. Uncompiled it was 1.7 times faster than Mark's for short list and nearly 15 times faster for long lists (8 times and nearly 300 times faster, respectively, than the Fold solution).
Unfortunately, I could not get good numbers for the compiled versions of either {Min[#], Max[#]}&, Leonid's, or Mark's answers, instead I got numerous incomprehensible error messages. In fact, {Min[#], Max[#]}& increased in execution time. The Fold solution improved dramatically, though, and took twice as long as Leonid's answers' uncompiled times.
Edit: for the curious, here's some timing measurements of the uncompiled functions -
Each function was used on 100 lists of the length specified on the horizontal axis and the average time, in seconds, is the vertical axis. In ascending order of time, the curves are {Min[#], Max[#]}&, Mark's answer, Leonid's second answer, Leonid's first answer, and the Fold method from above.
For all of you who are doing timings I'd like to warn you that order of execution is extremely important. For instance, look at the following two subtly different timings tests:
(1)
res =
Table[
a = RandomReal[{0, 100}, 10^8];
{
Min[a] // AbsoluteTiming // First, Max[a] // AbsoluteTiming // First,
Max[a] // AbsoluteTiming // First, Min[a] // AbsoluteTiming // First
}
, {100}
]
The odd man out here is the last Min
(2)
res =
Table[
a = RandomReal[{0, 100}, 10^8];
{
Max[a] // AbsoluteTiming // First, Min[a] // AbsoluteTiming // First,
Min[a] // AbsoluteTiming // First, Max[a] // AbsoluteTiming // First
}
, {100}
]
Here, the highest timing is found for the first Max, the second-highest for the second max and the two Mins are about the same and lowest. Actually, I'd expect Max and Min to take about the same time,but they don't. The former seems to take 50% more time than the latter. Having the pole position also seems to come with a 50% handicap.
Now a comparison with the algorithms given by Mark and Leonid:
res =
Table[
a = RandomReal[{0, 100}, 10^8];
{
{Max[a], Min[a]} // AbsoluteTiming // First,
{Min##, Max##} &#a // AbsoluteTiming // First,
getMinMax[a] // AbsoluteTiming // First,
minMax[a] // AbsoluteTiming // First,
{Min[a], Max[a]} // AbsoluteTiming // First
}
, {100}
]
Here we find about .3 s for the {Max[a], Min[a]} (which includes the pole position handicap), the .1 level is for Mark's method; the others are all about the same.

How would you look at developing an algorithm for this hotel problem?

There is a problem I am working on for a programming course and I am having trouble developing an algorithm to suit the problem. Here it is:
You are going on a long trip. You start on the road at mile post 0. Along the way there are n
hotels, at mile posts a1 < a2 < ... < an, where each ai is measured from the starting point. The
only places you are allowed to stop are at these hotels, but you can choose which of the hotels
you stop at. You must stop at the final hotel (at distance an), which is your destination.
You'd ideally like to travel 200 miles a day, but this may not be possible (depending on the spacing
of the hotels). If you travel x miles during a day, the penalty for that day is (200 - x)^2. You want
to plan your trip so as to minimize the total penalty that is, the sum, over all travel days, of the
daily penalties.
Give an efficient algorithm that determines the optimal sequence of hotels at which to stop.
So, my intuition tells me to start from the back, checking penalty values, then somehow match them going back the forward direction (resulting in an O(n^2) runtime, which is optimal enough for the situation).
Anyone see any possible way to make this idea work out or have any ideas on possible implmentations?
If x is a marker number, ax is the mileage to that marker, and px is the minimum penalty to get to that marker, you can calculate pn for marker n if you know pm for all markers m before n.
To calculate pn, find the minimum of pm + (200 - (an - am))^2 for all markers m where am < an and (200 - (an - am))^2 is less than your current best for pn (last part is optimization).
For the starting marker 0, a0 = 0 and p0 = 0, for marker 1, p1 = (200 - a1)^2. With that starting information you can calculate p2, then p3 etc. up to pn.
edit: Switched to Java code, using the example from OP's comment. Note that this does not have the optimization check described in second paragraph.
public static void printPath(int path[], int i) {
if (i == 0) return;
printPath(path, path[i]);
System.out.print(i + " ");
}
public static void main(String args[]) {
int hotelList[] = {0, 200, 400, 600, 601};
int penalties[] = {0, (int)Math.pow(200 - hotelList[1], 2), -1, -1, -1};
int path[] = {0, 0, -1, -1, -1};
for (int i = 2; i <= hotelList.length - 1; i++) {
for(int j = 0; j < i; j++){
int tempPen = (int)(penalties[j] + Math.pow(200 - (hotelList[i] - hotelList[j]), 2));
if(penalties[i] == -1 || tempPen < penalties[i]){
penalties[i] = tempPen;
path[i] = j;
}
}
}
for (int i = 1; i < hotelList.length; i++) {
System.out.print("Hotel: " + hotelList[i] + ", penalty: " + penalties[i] + ", path: ");
printPath(path, i);
System.out.println();
}
}
Output is:
Hotel: 200, penalty: 0, path: 1
Hotel: 400, penalty: 0, path: 1 2
Hotel: 600, penalty: 0, path: 1 2 3
Hotel: 601, penalty: 1, path: 1 2 4
It looks like you can solve this problem with dynamic programming. The subproblem is the following:
d(i) : The minimum penalty possible when travelling from the start to hotel i.
The recursive formula is as follows:
d(0) = 0 where 0 is the starting position.
d(i) = min_{j=0, 1, ... , i-1} ( d(j) + (200-(ai-aj))^2)
The minimum penalty for reaching hotel i is found by trying all stopping places for the previous day, adding today's penalty and taking the minimum of those.
In order to find the path, we store in a separate array (path[]) which hotel we had to travel from in order to achieve the minimum penalty for that particular hotel. By traversing the array backwards (from path[n]) we obtain the path.
The runtime is O(n^2).
This is equivalent to finding the shortest path between two nodes in a directional acyclic graph. Dijkstra's algorithm will run in O(n^2) time.
Your intuition is better, though. Starting at the back, calculate the minimum penalty of stopping at that hotel. The first hotel's penalty is just (200-(200-x)^2)^2. Then, for each of the other hotels (in reverse order), scan forward to find the lowest-penalty hotel. A simple optimization is to stop as soon as the penalty costs start increasing, since that means you've overshot the global minimum.
I don't think you can do it as easily as sysrqb states.
On a side note, there is really no difference to starting from start or end; the goal is to find the minimum amount of stops each way, where each stop is as close to 200m as possible.
The question as stated seems to allow travelling beyond 200m per day, and the penalty is equally valid for over or under (since it is squared). This prefers an overage of miles per day rather than underage, since the penalty is equal, but the goal is closer.
However, given this layout
A ----- B----C-------D------N
0 190 210 390 590
It is not always true. It is better to go to B->D->N for a total penalty of only (200-190)^2 = 100. Going further via C->D->N gives a penalty of 100+400=500.
The answer looks like a full breadth first search with active pruning if you already have an optimal solution to reach point P, removing all solutions thus far where
sum(penalty-x) > sum(penalty-p) AND distance-to-x <= distance-to-p - 200
This would be an O(n^2) algorithm
Something like...
Quicksort all hotels by distance from start (discard any that have distance > hotelN)
Create an array/list of solutions, each containing (ListOfHotels, I, DistanceSoFar, Penalty)
Inspect each hotel in order, for each hotel_I
Calculate penalty to I, starting from each prior solution
Pruning
For each prior solution that is beyond 200 distanceSoFar from
current, and Penalty>current.penalty, remove it from list
loop
Following is the MATLAB code for hotel problem.
clc
clear all
% Data
% a = [0;50;180;150;50;40];
% a = [0, 200, 400, 600, 601];
a = [0,10,180,350,450,600];
% a = [0,1,2,3,201,202,203,403];
n = length(a);
opt(1) = 0;
prev(1)= 1;
for i=2:n
opt(i) =Inf;
for j = 1:i-1
if(opt(i)>(opt(j)+ (200-a(i)+a(j))^2))
opt(i)= opt(j)+ (200-a(i)+a(j))^2;
prev(i) = j;
end
end
S(i) = opt(i);
end
k = 1;
i = n;
sol(1) = n;
while(i>1)
k = k+1;
sol(k)=prev(i);
i = prev(i);
end
for i =k:-1:1
stops(i) = sol(i);
end
stops
Step 1 of 2
Sub-problem:
In this scenario, "C(j)" has been considered as sub-problem for minimum penalty gained up to the hotel "ai" when "0<=i<=n". The required value for the problem is "C(n)".
Algorithm to find minimum total penalty:
If the trip is stopped at the location "aj" then the previous stop will be "ai" and the value of i and should be less than j. Then all the possibilities of "ai", has been follows:
C(j) min{C(i)+(200-(aj-ai))^2}, 0<=i<=j.
Initialize the value of "C(0)" as "0" and “a0" as "0" to find the remaining values.
To find the optimal route, increase the value of "j" and "i" for each iteration of and use this detail to backtrack from "C(n)".
Here, "C(n)" refers the penalty of the last hotel (That is, the value of "i" is between "0" and "n").
Pseudocode:
//Function definition
Procedure min_tot()
//Outer loop to represent the value of for j = 1 to n:
//Calculate the distance of each stop C(j) = (200 — aj)^2
//Inner loop to represent the value of for i=1 to j-1:
//Compute total penalty and assign the minimum //total penalty to
"c(j)"
C(j) = min (C(i), C(i) + (200 — (aj — ai))^2}
//Return the value of total penalty of last hotel
return C(n)
Step 2 of 2
Explanation:
The above algorithm is used to find the minimum total penalty from the starting point to the end point.
It uses the function "min()" to find the total penalty for the each stop in the trip and computes the minimum
penalty value.
Running time of the algorithm:
This algorithm contains "n" sub-problems and each sub-problem take "O(n)" times to resolve.
It is needed to compute only the minimum values of "O(n)".
And the backtracking process takes "O(n)" times.
The total running time of the algorithm is nxn = n^2 = O(n^2) .
Therefore, this algorithm totally takes "0(n^2)" times to solve the whole problem.
I have come across this problem recently and wanted to share my solution written in Javascript.
Not dissimilar to the most of the above solutions, I have used dynamic programming approach. To calculate penalties[i], we need to search for such stopping place for the previous day so that the penalty is minimum.
penalties(i) = min_{j=0, 1, ... , i-1} ( penalties(j) + (200-(hotelList[i]-hotelList[j]))^2) The solution does not assume that the first penalty is Math.pow(200 - hotelList[1], 2). We don't know whether or not it is optimal to stop at the first top so this assumption should not be made.
In order to find the optimal path and store all the stops along the way, the helper array path is being used. Finally, the array is being traversed backwards to calculate the finalPath.
function calculateOptimalRoute(hotelList) {
const path = [];
const penalties = [];
for (i = 0; i < hotelList.length; i++) {
penalties[i] = Math.pow(200 - hotelList[i], 2)
path[i] = 0
for (j = 0; j < i; j++) {
const temp = penalties[j] + Math.pow((200 - (hotelList[i] - hotelList[j])), 2)
if (temp < penalties[i]) {
penalties[i] = temp;
path[i] = (j + 1);
}
}
}
const finalPath = [];
let index = path.length - 1
while (index >= 0) {
finalPath.unshift(index + 1);
index = path[index] - 1;
}
console.log('min penalty is ', penalties[hotelList.length - 1])
console.log('final path is ', finalPath)
return finalPath;
}
// calculateOptimalRoute([20, 40, 60, 940, 1500])
// Outputs [3, 4, 5]
// calculateOptimalRoute([190, 420, 550, 660, 670])
// Outputs [1, 2, 5]
// calculateOptimalRoute([200, 400, 600, 601])
// Outputs [1, 2, 4]
// calculateOptimalRoute([])
// Outputs []
To answer your question concisely, a PSPACE-complete algorithm is usually considered "efficient" for most Constraint Satisfaction Problems, so if you have an O(n^2) algorithm, that's "efficient".
I think the simplest method, given N total miles and 200 miles per day, would be to divide N by 200 to get X; the number of days you will travel. Round that to the nearest whole number of days X', then divide N by X' to get Y, the optimal number of miles to travel in a day. This is effectively a constant-time operation. If there were a hotel every Y miles, stopping at those hotels would produce the lowest possible score, by minimizing the effect of squaring each day's penalty. For instance, if the total trip is 605 miles, the penalty for travelling 201 miles per day (202 on the last) is 1+1+4 = 6, far less than 0+0+25 = 25 (200+200+205) you would get by minimizing each individual day's travel penalty as you went.
Now, you can traverse the list of hotels. The fastest method would be to simply pick the hotel that is the closest to each multiple of Y miles. It's linear-time and will produce a "good" result. However, I do not think this will produce the "best" result in all cases.
The more complex but foolproof method is to get the two closest hotels to each multiple of Y; the one immediately before and the one immediately after. This produces an array of X' pairs, which can be traversed in all possible permutations in 2^X' time. You can shorten this by applying Dijkstra to a map of these pairs, which will determine the least costly path for each day's travel, and will execute in roughly (2X')^2 time. This will probably be the most efficient algorithm that is guaranteed to produce the optimal result.
As #rmmh mentioned you are finding minimum distance path. Here distance is penalty ( 200-x )^2
So you will try to find a stopping plan by finding minimum penalty.
Lets say D(ai) gives distance of ai from starting point
P(i) = min { P(j) + (200 - (D(ai) - D(dj)) ^2 } where j is : 0 <= j < i
From a casual analysis it looks to be
O(n^2) algorithm ( = 1 + 2 + 3 + 4 + .... + n ) = O(n^2)
As a proof of concept, here is my JavaScript solution in Dynamic Programming without nested loops.
We start at zero miles.
We find the next stop by keeping the penalty as low as we can by comparing the penalty of a current hotel in the loop to the previous hotel's penalty.
Once we have our current minimum, we have found our stop for the day. We assign this point as our next starting point.
Optionally, we could keep the total of the penalties:
let hotels = [40, 80, 90, 200, 250, 450, 680, 710, 720, 950, 1000, 1080, 1200, 1480]
function findOptimalPath(arr) {
let start = 0
let stops = []
for (let i = 0; i < arr.length; i++) {
if (Math.pow((start + 200) - arr[i-1], 2) < Math.pow((start + 200) - arr[i], 2)) {
stops.push(arr[i-1])
start = arr[i-1]
}
}
console.log(stops)
}
findOptimalPath(hotels)
Here is my Python solution using Dynamic Programming:
distance = [150,180,250,340]
def hotelStop(distance):
n = len(distance)
DP = [0 for _ in distance]
for i in range(n-2,-1,-1):
min_penalty = float("inf")
for j in range(i+1,n):
# going from hotel i to j in first day
x = distance[j]-distance[i]
penalty = (200-x)**2
total_pentalty = penalty+ DP[j]
min_penalty = min(min_penalty,total_pentalty)
DP[i] = min_penalty
return DP[0]
hotelStop(distance)

Identify important minima and maxima in time-series w/ Mathematica

I need a way to identify local minima and maxima in time series data with Mathematica. This seems like it should be an easy thing to do, but it gets tricky. I posted this on the MathForum, but thought I might get some additional eyes on it here.
You can find a paper that discusses the problem at: http://www.cs.cmu.edu/~eugene/research/full/compress-series.pdf
I've tried this so far…
Get and format some data:
data = FinancialData["SPY", {"May 1, 2006", "Jan. 21, 2011"}][[All, 2]];
data = data/First#data;
data = Transpose[{Range[Length#data], data}];
Define 2 functions:
First method:
findMinimaMaxima[data_, window_] := With[{k = window},
data[[k + Flatten#Position[Partition[data[[All, 2]], 2 k + 1, 1], x_List /; x[[k + 1]] < Min[Delete[x, k + 1]] || x[[k + 1]] > Max[Delete[x, k + 1]]]]]]
Now another approach, although not as flexible:
findMinimaMaxima2[data_] := data[[Accumulate#(Length[#] & /# Split[Prepend[Sign[Rest#data[[All, 2]] - Most#data[[All, 2]]], 0]])]]
Look at what each the functions does. First findMinimaMaxima2[]:
minmax = findMinimaMaxima2[data];
{Length#data, Length#minmax}
ListLinePlot#minmax
This selects all minima and maxima and results (in this instance) in about a 49% data compression, but it doesn't have the flexibility of expanding the window.
This other method does. A window of 2, yields fewer and arguably more important extrema:
minmax2 = findMinimaMaxima[data, 2];
{Length#data, Length#minmax2}
ListLinePlot#minmax2
But look at what happens when we expand the window to 60:
minmax2 = findMinimaMaxima[data, 60];
ListLinePlot[{data, minmax2}]
Some of the minima and maxima no longer alternate.
Applying findMinimaMaxima2[] to the output of findMinimaMaxima[] gives a workaround...
minmax3 = findMinimaMaxima2[minmax2];
ListLinePlot[{data, minmax2, minmax3}]
, but this seems like a clumsy way to address the problem.
So, the idea of using a fixed window to look left and right doesn't quite do everything one would like. I began thinking about an alternative that could use a range value R (e.g. a percent move up or down) that the function would need to meet or exceed to set the next minima or maxima. Here's my first try:
findMinimaMaxima3[data_, R_] := Module[{d, n, positions},
d = data[[All, 2]];
n = Transpose[{data[[All, 1]], Rest#FoldList[If[(#2 <= #1 + #1*R && #2 >= #1) || (#2 >= #1 - #1* R && #2 <= #1), #1, #2] &, d[[1]], d]}];
n = Sign[Rest#n[[All, 2]] - Most#n[[All, 2]]];
positions = Flatten#Rest[Most[Position[n, Except[0]]]];
data[[positions]]
]
minmax4 = findMinimaMaxima3[data, 0.1];
ListLinePlot[{data, minmax4}]
This too benefits from post processing with findMinimaMaxima2[]
ListLinePlot[{data, findMinimaMaxima2[minmax4]}]
But if you look closely, you see that it misses the extremes if they go beyond the R value in several positions - including the chart's absolute minimum and maximum as well as along the big moves up and down. Changing the R value shows how it misses the top and bottoms even more:
minmax4 = findMinimaMaxima3[data, 0.15];
ListLinePlot[{data, minmax4}]
So, I need to reconsider. Anyone can look at a plot of the data and easily identify the important minima and maxima. It seems harder to get an algorithm to do it. A window and/or an R value seem important to the solution, but neither on their own seems enough (at least not in the approaches above).
Can anyone extend any of the approaches shown or suggest an alternative to identifying the important minima and maxima?
Happy to forward a notebook with all of this code and discussion in it. Let me know if anyone needs it.
Thank you,
Jagra
I suggest to use an iterative approach. The following functions are taken from this post, and while they can be written more concisely without Compile, they'll do the job:
localMinPositionsC =
Compile[{{pts, _Real, 1}},
Module[{result = Table[0, {Length[pts]}], i = 1, ctr = 0},
For[i = 2, i < Length[pts], i++,
If[pts[[i - 1]] > pts[[i]] && pts[[i + 1]] > pts[[i]],
result[[++ctr]] = i]];
Take[result, ctr]]];
localMaxPositionsC =
Compile[{{pts, _Real, 1}},
Module[{result = Table[0, {Length[pts]}], i = 1, ctr = 0},
For[i = 2, i < Length[pts], i++,
If[pts[[i - 1]] < pts[[i]] && pts[[i + 1]] < pts[[i]],
result[[++ctr]] = i]];
Take[result, ctr]]];
Here is your data plot:
dplot = ListLinePlot[data]
Here we plot the mins, which are obtained after 3 iterations:
mins = ListPlot[Nest[#[[localMinPositionsC[#[[All, 2]]]]] &, data, 3],
PlotStyle -> Directive[PointSize[0.015], Red]]
The same for maxima:
maxs = ListPlot[Nest[#[[localMaxPositionsC[#[[All, 2]]]]] &, data, 3],
PlotStyle -> Directive[PointSize[0.015], Green]]
And the resulting plot:
Show[{dplot, mins, maxs}]
You may vary the number of iterations, to get more coarse-grained or finer minima/maxima.
Edit:
actually, I just noticed that a couple of points were still missed by this method, both for the
minima and maxima. So, I suggest it as a starting point, not as a complete solution. Perhaps, you
could analyze minima/maxima, coming from different iterations, and sometimes include those from a "previous", more fine-grained one. Also, the only "physical reason" that this kind of works, is that the nature of the financial data appears to be fractal-like, with several distinctly different scales. Each iteration in the above Nest-s targets a particular scale. This would not work so well for an arbitrary signal.

Resources