<< Graphics`

Preliminary setup (READ THIS FIRST)

First, we need to make a few definitions to make our work a bit easier.

Let's define a generalized gradient function (the one built into Mathematica is strictly for functions of 3 variables):

grad[scalarFunction_, variableList_?VectorQ] := 
      Table[(∂_(variableList[[i]])) scalarFunction, {i, 
          Length[variableList]}]

(This makes a vector by differentiating by each element of the variableList successively.  The ?VariableQ part forces you to enter the list of variables.)

The way you use this function is as follows:

grad[(x^2) - 2  x y, {x, y}]

Or, for a function of 3 variables:

grad[Sin[x y] Cos[z], {x, y, z}]

Or, for that matter, you can use it on a function of 6 variables:

grad[(a^2) (b^3) Sin[c d] - e Log[f], {a, b, c, d, e, 
        f}]

We also can do the following to make life easier:

SetAttributes[Equal, Listable]

This makes it easier to set vector equations equal to each other and solve them:

f[x_, y_] := (x^2) - 2  x + 3  (y^2)

∇f = grad[f[x, y], {x, y}]

system = ∇f == {0, 0}

Solve[∇f == {0, 0}, {x, y}]

(Hint:  we just found the critical points of this function.)

Optimization - No constraints

Finding critical points using Solve

To find the critical points of a function, you need to find all points where the gradient is equal to the zero vector or undefined.  So, we can use the definition I made for grad earlier:

f[x_, y_] := (x^3) - 2  x + 3  (y^2) - 5  y

∇f = grad[f[x, y], {x, y}]

This is never undefined, so we just need to set each component equal to 0 and solve the system of equations:

critPts = Solve[∇f == {0, 0}, {x, y}]

There are two critical points for this function.  (Notice the compact way we do this.  You could type in the equations individually, but this is much nicer.)  Also, we give the set of critical points a name (critPts) so we can refer back to them later and use them to calculate with.  You can get Mathematica to pick out a single one of these points using the following notation:

critPts[[1]]

critPts[[2]]

(Yes, you have to use the double square brackets like this.)

Of course, now you have to decide whether each of these is a local minimum, maximum, saddle point, or none of these.  One way to do this would be to graph the function around the critical points and see what it looks like:

Plot3D[f[x, y], {x, -2, 2}, {y, -2, 2}]

(I deleted the graph above so the file will fit on a floppy...)

Perhaps you can tell what we have here.  If you were to "zoom in" on each critical point more closely (i.e., change your domain displayed), you could probably tell better.  However, it is often easier to look at the contour plot instead:

ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}, 
      Contours -> 50, PlotPoints -> 50]

Notice that this makes it much clearer what is going on.  (It is often useful to use the Contours->50 or some large number so all minima/maxima get completely encircled.)  So, the critical point with the positive x value is a minimum, while the one with the negative x value is a saddle point.  (Be certain that you understand how to tell this from the graph before continuing.)

Let's use the 2 variable second derivative test to check this for sure.  In doing this, I will demonstrate a few tricks you can do with Mathematica to streamline this process (cutting and pasting gets to be a big pain after awhile).

We could do this a couple of different ways.  First, lets define D from the second derivative test:

secondDerivTest = (∂_(x, x))f[x, y] (∂_(y, y))f[
              x, y] - ((((∂_(x, y))f[x, y]))^2)

Now, to plug the critical points in, we could cut and paste them (bad idea), or we could use the replacement operator /.

secondDerivTest  /. {y -> (5/6), x -> (Sqrt[(2/3)])}

This replaces x with (Sqrt[(2/3)]) and y with (5/6).  These are called replacement rules. However, if you notice, our list of critical points is already composed of a list of these replacement rules:

critPts

So, we could do the following:

secondDerivTest  /. critPts

The first value corresponds to the value at the first critical point and the second one to the second point.  You can do the same thing to check (Subscript[f, x,x ]):

(∂_(x, x))f[x, y] /. critPts

We can handle all of our critical points simultaneously by doing things this way.  Thus, the first critical point has a negative value for D, so it is a saddle point.  The second critical point has a positive D and (Subscript[f, x, x]) is positive, so it is a minimum.

Finding critical points using FindRoot/FindMinimum

Unfortunately, Solve doesn't always work to find the critical points (if your function is exponential or trigonometric, for example).  In this case, there are two options.

Use FindRoot

The problem here is that, since it is based on Newton's method, you need an initial guess.  This means two things:  First, you need to look at a graph of the function (contour lines are good here) to make a reasonable guess.  Second, you can only realistically find critical points in a particular region (not true if Solve works; you can find all critical points then).  After finding each critical point, you still have to classify it (min/max/saddle point/neither).

Use FindMinimum

This command is kind of like the FindRoot command (i.e., you must give it an initial guess), but it then automatically finds a nearby minimum of the function.  This has the advantage that you know your answer will be a minimum.  Of course, it won't help you find saddle points.  You can find a maximum by using FindMinimum on -f(x, y), so the minimum of -f(x, y) will be the maximum of f(x, y).

Example

Consider the function:

f[x_, 
        y_] := (2  y - x + (E^(1 - (x^2) - (y^2))))/(1 + 
            (x^2) + (y^2))

∇f = grad[f[x, y], {x, y}]

Solve[∇f == {0, 0}, {x, y}]

In other words, forget it.  So, let's get a quick look at this near the origin:

ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}, 
      Contours -> 20, PlotPoints -> 40]

It appears there is a minimum around (0.8,-1.5) and a maximum around (0,0.2) or so.  Let's find them:

FindRoot[∇f, {x, 0.8}, {y, -1.5}]

FindRoot[∇f, {x, 0}, {y, 0.2}]

You can use the graph (or the second derivative test) to see what each of these is.  If there were a saddle point, you could find it this way as well.

Or, using the FindMinimum command:

FindMinimum[f[x, y], {x, 0}, {y, 0}]

Notice that you use this command on f(x, y), not on ∇f  (and it gives you the value of the function at the point as an added bonus).  Also, since there is only one minimum nearby, you don't have to be very accurate with your initial guess.

In order to find the maximum:

FindMinimum[-f[x, y], {x, 0}, {y, 0}]

You would not be able to find saddle points reliably this way, however.  (Sometimes it will find them, but not always.)

Problems:

For each of the following, find the critical points, show them graphically on a contour plot (and 3-D if you wish), and classify them using the second derivative test as minima/maxima/saddle points/none of these.  If possible, use Solve to find all critical points.  If Solve doesn't work (or you don't get an answer back from it in a few minutes of waiting), then use FindRoot or FindMinimum to find all critical points on the region -2 ≤ x ≤ 
        2 and  - 2 ≤ y ≤ 2.

1.

f[x_, 
        y_] := ((y^2) - y + x y + 
            Log[(x^4) + (y^2) + 
                1]) (E^(-((x^2) + (y^2))))

2.

f[x_, y_] := 
      5  y - (y^3) - 2 (( x )^2) y + 3  x

Curve fitting using the method of Least Squares

One of the important applications of optimizing a multi-variable function is in finding a function that fits a set of experimental data.  This is useful in many fields, from applied science to economics.  Most spreadsheet, like Excel, have a built-in function to fit data to certain functions (usually called "regression" or something similar).  You can use Mathematica to fit your data to any function you wish, however.  

So, first we need some data to work with (it is possible to read this in from an external file, if you save it as a text file):

dataSet = {{0, -8.644412242139174`}, {1.`, 
            6.36983059812407`}, {2.`, 3.1166920538346634`}, {3.`, 
            16.534923962027378`}, {4.`, 17.28546439401197`}, {5.`, 
            14.042067682369016`}, {6.`, 29.67441157387531`}, {7.`, 
            31.892651694887128`}, {8.`, 25.187987568268625`}, {9.`, 
            33.50299780522195`}, {10.`, 37.5350851739895`}, {11.`, 
            41.804132220144915`}, {12.`, 46.673536373409014`}, {13.`, 
            51.31729013748644`}, {14.`, 51.428028230851666`}, {15.`, 
            64.48691715222478`}, {16.`, 55.879218441093954`}, {17.`, 
            76.16003134379929`}, {18.`, 73.19300996826124`}, {19.`, 
            74.48592658271696`}, {20.`, 90.48679882846014`}, {21.`, 
            89.55814982445182`}, {22.`, 87.06754392046815`}, {23.`, 
            87.27997238153488`}, {24.`, 105.91709124294056`}, {25.`, 
            93.9617805682085`}, {26.`, 98.71189437805373`}, {27.`, 
            109.49367210046722`}, {28.`, 111.3678316994278`}, {29.`, 
            106.64349890587818`}, {30.`, 119.7488499937566`}, {31.`, 
            132.29996876469778`}, {32.`, 124.86637365981635`}, {33.`, 
            135.81461179885287`}, {34.`, 128.87545668750323`}, {35.`, 
            141.14510958182848`}, {36.`, 152.82969149322244`}, {37.`, 
            143.12175703772104`}, {38.`, 160.0594450025457`}, {39.`, 
            163.2577901450373`}, {40.`, 167.53765193710154`}, {41.`, 
            161.5364857484343`}, {42.`, 165.42877625833646`}, {43.`, 
            171.32178595591188`}, {44.`, 183.58835667177243`}, {45.`, 
            182.50342065665296`}, {46.`, 192.87389824007832`}, {47.`, 
            182.5420606461265`}, {48.`, 200.15909367012085`}, {49.`, 
            195.01704949927293`}, {50.`, 204.62499444239253`}};

We can use the ListPlot command to take a look at all this data:

dataGraph = ListPlot[dataSet]

This looks basically linear, so let's see if we can find the "best" linear fit for this data.  (The deviations from a linear graph could be due to experimental error, chance, or other complicating factors.)  There are different definitions of what line/curve would best fit this data, but the one we will use is called the "least square fit".  The idea is to define a function with appropriate unknown parameters:

linearFit[x_] := a x + b

where a and b are the parameters you are trying to find.  

Now, at each point we want to examine the "residual", which is the difference between f(x) and the actual y value of the data.  This tells you how far the actual data point is from the line.  So, for example, at x=1, the residual would be a(1) + b - 6.36983059812407, which is a function of the parameters a and b.  You could then add together the residuals for all the points.  This would give you the total amount all the data points differ from a given line.  For the "best" line, you would like this total of the residuals to be as small as possible (so it is the "closest" line to as many points as possible).  

Unfortunately, since some points are above the line and some are below it, some of their residuals will cancel out (some are positive and some negative).  We can fix this by squaring each residual to make it positive.  If we then minimize the sum of these squares of the residuals, we will find the line that is the "closest" to the most points.  This is called the "method of least squares".

So, to actually set this up, we could do the following:

howManyPts = Length[dataSet]

sumOfSquares = (∑_(j = 1)^howManyPts)(((linearFit[dataSet[[j, 1]]] - dataSet[[j, 2]]))^2)

In this function, dataSet[[j,1]] refers to the x coordinate of the (j^th) point and dataSet[[j,2]] refers to the y coordinate.  (howManyPts tells you exactly what it says...)  

Now, sumOfSquares is a function of two variables a and b, which we want to minimize.  So we can simply find the critical points and decide whether they are minima or not.

∇sumOfSquares = grad[sumOfSquares, {a, b}]

bestCoef = Solve[∇sumOfSquares == {0, 0}, {a, b}]

Since there is only one critical point, you should be able to convince yourself that this is indeed a minimum by any of the methods mentioned above (or by simple logic; it can't be a maximum since you can always make the line as far from the data as you want).  The best fit line is therefore:

f[x_] := linearFit[x] /. bestCoef

f[x]

Let's plot both the data and the line we just found together on the same graph:

curve = Plot[f[x], {x, 0, 50}]

Show[dataGraph, curve]

If your data doesn't look like it is linear, then you need to decide what kind of function it does look like.  Then, use the formula for that type of function with appropriate parameters and use the same process on it (using a different function besides linearFit).  

Here are some typical functions you might use:

parabolicFit[x_] := a (x^2) + b x + c

cubicFit[x_] := a (x^3) + b (x^2) + c x + d

exponentialFit[x_] := a (E^(-b x)) + c

exponentialXFit[x_] := 
      a (x^2) (E^(-b (x^2))) + c

logisticFit[
        x_]:=((a b)/(a + (b - 
                  a) (E^(-c x))))

On this last one, you may assume that a < b and a, b, c>0.

When finding the critical points, if Solve doesn't work, then you are forced to use FindMinimum (or FindRoot, though FindMinimum would probably be better here).  For the functions with 3 (or more) parameters, it can be tricky to pick a starting guess.  Sometimes it is useful to just pick anything reasonable for a starting guess (thinking about x or y-intercepts and any asymptotes, for example).  If Mathematica gives you an error message saying something like "Machine precision is insufficient to achieve the requested accuracy or precision.", then take the answers it gives you for this and use those numbers for your initial guess instead.

Problem:  For each of the last 3 functions above, graph them with some different values for the coefficients, so you can get an idea of what they look like.  Give a brief explanation of the roles of the parameters in the last 3 (i.e., what is the y-intercept, horizontal asymptote, etc.).  Look especially for their behavior in the 1st quadrant.

Problems - Choose any TWO of the following:

1.

dataSet = {{0, 0.8251126545285254`}, {0.5`, 
            3.1276916710018345`}, {1.`, 4.52048488123474`}, {1.5`, 
            5.912653230679171`}, {2.`, 6.718970832016174`}, {2.5`, 
            7.757375051117126`}, {3.`, 7.894583645686959`}, {3.5`, 
            8.645107647640222`}, {4.`, 9.07596356012445`}, {4.5`, 
            9.505621861917753`}, {5.`, 10.528467588254847`}, {5.5`, 
            10.695390972100697`}, {6.`, 10.50149543382819`}, {6.5`, 
            10.555159191926524`}, {7.`, 10.80670085694237`}, {7.5`, 
            10.897262921422183`}, {8.`, 11.005506825077775`}, {8.5`, 
            11.46820202143342`}, {9.`, 11.903272726722859`}, {9.5`, 
            11.430134344469526`}, {10.`, 11.353970790744663`}, {10.5`, 
            11.92142405334536`}, {11.`, 12.002360276388085`}, {11.5`, 
            12.133515788583354`}, {12.`, 12.083120364169474`}, {12.5`, 
            12.134610700574893`}, {13.`, 11.515060912822019`}, {13.5`, 
            12.300527825537424`}, {14.`, 11.684962204059312`}, {14.5`, 
            11.567687733840991`}, {15.`, 12.337313247429703`}, {15.5`, 
            12.178982988495518`}, {16.`, 11.639342302349815`}, {16.5`, 
            12.315708476233183`}, {17.`, 11.616057263512676`}, {17.5`, 
            11.586129274134397`}, {18.`, 12.287060847213258`}, {18.5`, 
            12.315804979858154`}, {19.`, 12.33671261052288`}, {19.5`, 
            12.359972984700946`}, {20.`, 12.272731104540439`}};

2.

dataSet = {{0, -0.8825643293867005`}, {0.2`, 
            7.640262878668185`}, {0.4`, 
            16.1707127325383`}, {0.6000000000000001`, 
            16.32655532926327`}, {0.8`, 23.395467080119985`}, {1.`, 
            25.98651576393184`}, {1.2000000000000002`, 
            31.708788378073244`}, {1.4000000000000001`, 
            30.55450545842563`}, {1.6`, 33.22957465983089`}, {1.8`, 
            35.28026680083259`}, {2.`, 34.84937211735932`}, {2.2`, 
            30.778678241736962`}, {2.4000000000000004`, 
            33.50552201258932`}, {2.6`, 
            32.945804601910424`}, {2.8000000000000003`, 
            31.565145226357288`}, {3.`, 29.787414385447498`}, {3.2`, 
            23.910731283367305`}, {3.4000000000000004`, 
            21.781054640371234`}, {3.6`, 
            19.391210201906215`}, {3.8000000000000003`, 
            15.087680108104196`}, {4.`, 16.242662853616753`}, {4.2`, 
            9.777238619615302`}, {4.4`, 
            5.826999714935477`}, {4.6000000000000005`, 
            6.98570937106039`}, {4.800000000000001`, 
            3.415627183003443`}, {5.`, 
            2.177975740947118`}, {5.2`, -3.344113017602818`}, {5.4`, -2.1218459582028744`}, {5.6000000000000005`, -1.2278398971165307`}, {5.800000000000001`, -6.157140022984725`}, {6.`, -7.082901395676055`}, {6.2`, -6.915751416628503`}, {6.4`, -5.381414556947412`}, {6.6000000000000005`, -3.4684068238173067`}, {6.800000000000001`, -1.4398735130353675`}, {7.`, -0.9954296583654629`}, {7.2`, 5.754663430463269`}, {7.4`, 
            9.958788574272269`}, {7.6000000000000005`, 
            14.940981260607348`}, {7.800000000000001`, 
            18.630555956187063`}, {8.`, 26.671932147095962`}};

3.

dataSet = {{0, 
            1.3477494780390806`}, {0.2`, -0.7532462114832299`}, {0.4`, 
            8.755568330264024`}, {0.6000000000000001`, 
            6.5552990375867415`}, {0.8`, 17.531100218033217`}, {1.`, 
            17.710428223676367`}, {1.2000000000000002`, 
            30.220805272039037`}, {1.4000000000000001`, 
            42.48509996213261`}, {1.6`, 46.90431153040936`}, {1.8`, 
            50.11554613728803`}, {2.`, 59.1234147265948`}, {2.2`, 
            70.52286017783408`}, {2.4000000000000004`, 
            80.52328775648044`}, {2.6`, 
            86.6816181177613`}, {2.8000000000000003`, 
            82.66904491520052`}, {3.`, 90.65921778502779`}, {3.2`, 
            94.21614745856911`}, {3.4000000000000004`, 
            90.73379207408404`}, {3.6`, 
            98.1609836622042`}, {3.8000000000000003`, 
            90.61250128590801`}, {4.`, 95.4410402088509`}, {4.2`, 
            91.44333131161792`}, {4.4`, 
            91.34735471740109`}, {4.6000000000000005`, 
            77.99246803833697`}, {4.800000000000001`, 
            76.07061300997903`}, {5.`, 72.63121144536404`}, {5.2`, 
            63.638561255785206`}, {5.4`, 
            55.14666826785147`}, {5.6000000000000005`, 
            58.78403097402034`}, {5.800000000000001`, 
            49.33099305468795`}, {6.`, 47.332429014395245`}, {6.2`, 
            35.0919319899874`}, {6.4`, 
            31.4892289598518`}, {6.6000000000000005`, 
            28.314948449434638`}, {6.800000000000001`, 
            26.76652406524611`}, {7.`, 24.23273186882953`}, {7.2`, 
            19.09817101723772`}, {7.4`, 
            17.35379615052732`}, {7.6000000000000005`, 
            14.332262357739735`}, {7.800000000000001`, 
            9.10777828692763`}, {8.`, 
            16.41354902761196`}, {8.200000000000001`, 
            8.81116087501498`}, {8.4`, 11.697322475119481`}, {8.6`, 
            2.087245468990462`}, {8.8`, 3.453441369547319`}, {9.`, 
            9.68149645754063`}, {9.200000000000001`, 
            9.58174955558855`}, {9.4`, 
            9.484754928748954`}, {9.600000000000001`, 
            8.331507922390596`}, {9.8`, 1.117679697571241`}, {10.`, 
            4.842193432146992`}};

Bonus:  Do the third problem above for a bonus.

Optimization - With constraints

Lagrange multipliers

Fortunately, the method of Lagrange multipliers can be relatively easy to implement using Mathematica.  For example, if you need to optimize f (x, y) = 3  (x^2) (y^2) subject to the contraint that (x^2) + (y^2) = 4, you could set it up as follows:

f[x_, y_] := 3  (x^2) (y^2)

∇f = grad[f[x, y], {x, y}]

g[x_, y_] := (x^2) + (y^2)

∇g = grad[g[x, y], {x, y}]

system = {∇f == λ ∇g, g[x, y] == 4} // 
        Flatten

The //Flatten command at the end is necessary here for the Solve command to work properly with this.  It strips out the extra {}'s you would get otherwise.  Now you can use the Solve command to solve the system (even though you don't care what λ equals, you should still solve for it):

solutionPts = Solve[system, {x, y, λ}]

Notice that, again, we can give a name to the entire set of solutions to this sytem.  This way, we can work with all of them at one time, or pick a single one out to work with. 

Now, we need to find which of these is the minimum and which is the maximum:

f[x, y] /. solutionPts

(This plugs all of the solution points into f and displays the results.)  So, the minimum value is 0 (which occurs at the first 4 solution points) and the maximum value is 12 (which occurs at the last 4 solution points).

What to do when Solve doesn't work

So, what do you do when the Solve command doesn't work here?  Not surprisingly, you use the FindRoot command.  This is both easier and harder than it is in the case of finding critical points.  To do this, you must display a contour plot and a graph of the contraint equation on the same axes.  So, let's consider optimizing f (x, 
            y) = ((x^2) + x y + (y^2) - 
              x) cos(π (Sqrt[ (x^2) + (y^2) + 1])) subject to 2  (x^2) + 3  (y^2) = 1.

f[x_, y_] := ((x^2) + x y + (y^2) - x) 
        Cos[π (Sqrt[ (x^2) + (y^2) + 1])]

∇f = grad[f[x, y], {x, y}]

g[x_, y_] := 2  (x^2) + 3  (y^2)

∇g = grad[g[x, y], {x, y}]

system = {∇f == λ ∇g, g[x, y] == 1} // 
        Flatten

solutionPts = Solve[system, {x, y, λ}]

Well, I left this running for over 2 hours and it still hadn't come up with a solution, so it's time to look at the FindRoot function.  However, to use it, we need an initial guess.  This is trickier than it was with finding critical points.  Remember, what you are looking for is where the gradients of f and g are parallel.  An easier thing to look for, however, is where the contour curves are "parallel" (which is equivalent, if you think about it).  

So, first, let's graph the contour plot for f on the same graph with g (not contour curves):

fContourGraph = 
      ContourPlot[f[x, y], {x, -0.75, 0.75}, {y, -0.75, 0.75}, 
        Contours -> 50, PlotPoints -> 50, 
        ContourShading -> False]

gGraph = 
      ImplicitPlot[
        g[x, y] == 1, {x, -0.75, 0.75}, {y, -0.75, 
          0.75}]

Show[fContourGraph, gGraph]

Notice that we don't have to see all of f; we only need to see the region around the constraint curve g.  According to this graph, it looks like there are probably two points where the contour curves run parallel to g:  near (0.6,-0.4) and near (-0.6,-0.2).  Let's use those as our initial guesses for FindRoot.  Since we have no idea what λ equals for those points (and we don't really care), we will just guess that λ = 0.

solution1 = 
      FindRoot[system, {x, 0.6}, {y, -0.4}, {λ, 0}]

f[x, y] /. solution1

Now let's check the other one:

solution2 = 
      FindRoot[system, {x, -0.6}, {y, -0.4}, {λ, 
          0}]

f[x, y] /. solution2

Therefore, solution1 is the minimum and solution2 is the maximum.  (There are fancier ways to check both of these at the same time, but I am trying to keep things simple here.)

The problem with this method is that it isn't always easy to find all the places where the curves are parallel.

Problems:

For each of the following, find the minimum and maximum values of the function f subject to the given restriction.  If f is a function of two variables, plot its contours and the constraint on the same graph.  If Solve doesn't work (or you don't get an answer back from it in a few minutes of waiting), then use FindRoot instead, using your graph to pick your initial guesses.  Hint:  If you have a function of more than two variables, you treat it exactly the same as a function of two variables (our grad function can handle this, as long as you remember to give it a list of all the variables), except you have to adjust all the variable lists appropriately. (Also, really hope that Solve works on these.  It would be very hard to find them one at a time with FindRoot.)

1.

f[x_, y_, z_, w_] := 4  (y^2) - 5  (x^2) + 2  (w^2) - 3  (z^2)

subject to (x^2) + (y^2) + 3  (z^2) + 4  (w^2) = 10

2.

f[x_, 
        y_] := ((x y)/2) + (E^(-(x^2) - (y^2))) 
          Cos[π ((x^2) - y)]

subject to (x^2) + (y^2) = 1