For those wishing to follow along with the R-based demo in class, click here for the companion R-script for this lecture.

We can’t maximize a likelihood function without an optimization algorithm.

We can’t optimize a sampling or monitoring regime, as in the power analysis problem, without an optimization algorithm.

Clearly, we need optimization algorithms!! In addition, they provide an excellent example of how computer algorithms are so essential for modern data analysis.

You may not have built your own optimization algorithm before, but you’ve probably taken advantage of optimization algorithms that are operating behind the scenes. For example, if you have performed a glmm or a non-linear regression in R, you have exploited numerical optimization routines!

We will discuss optimization in the context of maximum likelihood estimation, and then we will discuss optimization and parameter estimation in a Bayesian context.

Let’s start with the most conceptually simple of all optimization algorithms – brute force!

NOTE: you won’t need to build your own optimization routines for this class- the code in this lecture is for demonstration purposes only!

Just like we did for the two-dimensional likelihood surface, we could evaluate the likelihood at tiny intervals across a broad range of parameter space. Then we can identify the parameter set associated with the maximum likelihood across all evaluated parameter sets (and the range of plausible parameter estimates!).

- Simple!! (conceptually very straightforward)

- Identify false peaks! (guaranteed to find the MLE!)

- Undeterred by discontinuities in the likelihood surface

- Speed: even slower and less efficient than a typical ecologist is
willing to accept! Practically impossible for complex multi-dimensional
problems (
*curse of dimensionality*)

- Resolution: we can only get the answer to within plus or minus the interval size.

Let’s use Bolker’s myxomatosis example dataset (an example we’ll return to frequently!) to illustrate:

```
# Explore Bolker's myxomatosis example -------------------------
library(emdbook) # this is the package provided to support the textbook!
library(ggplot2)
library(ggthemes)
MyxDat <- MyxoTiter_sum # load Bolker's example data
MyxDat$grade <- as.factor(MyxDat$grade)
ggplot(MyxDat,aes(day,titer)) +
geom_point(aes(col=grade)) +
facet_wrap(vars(grade), scales = "free") +
theme_clean()
```

```
Myx <- subset(MyxDat,grade==1) # subset: select most virulent
head(Myx)
```

```
## grade day titer
## 1 1 2 5.207
## 2 1 2 5.734
## 3 1 2 6.613
## 4 1 3 5.997
## 5 1 3 6.612
## 6 1 3 6.810
```

For this example, we’re modeling the distribution of measured titers (virus loads) for Australian rabbits. Bolker chose to use a Gamma distribution. Here is the empirical distribution:

`hist(Myx$titer,freq=FALSE) # distribution of virus loads`

We need to estimate the gamma ‘rate’ and ‘shape’ parameters that best fit this empirical distribution. Here is one example of a Gamma fit to this distribution:

```
# Overlay a gamma distribution on the histogram -------------------
hist(Myx$titer,freq=FALSE) # note the "freq=FALSE", which displays densities of observations, and therefore makes histograms comparable with probability density functions
curve(dgamma(x,shape=40,rate=6),add=T,col="red")
```

This is clearly not a great fit, but perhaps this would be an okay starting point (optimization algorithms don’t really require perfect starting points, just need to be in the ballpark)…

Let’s build a likelihood function for this problem!

```
# Build gamma likelihood function ---------------------
GammaLikelihoodFunction <- function(params){ # only one argument (params)- the data are hard-coded here (this is often the case with simple likelihood functions)
-sum(dgamma(Myx$titer,shape=params['shape'],rate=params['rate'],log=T)) # use params and data to compute likelihood
}
params <- c(shape=40,rate=6)
GammaLikelihoodFunction(params) # test the function!
```

`## [1] 38.74585`

Now let’s optimize using ‘optim()’ like we did before, to find the MLE!

NOTE: “optim()” will throw some warnings here because it will try to find the data likelihood for certain impossible parameter combinations!

```
# Optimize using R's built-in "optim()" function: find the maximum likelihood estimate
MLE <- optim(params,GammaLikelihoodFunction)
MLE$par
```

```
## shape rate
## 49.608753 7.164569
```

`MLE$value`

`## [1] 37.66714`

We can ignore the warnings!

Let’s visualize the fit of the MLE in this case…

```
# visualize the maximum likelihood fit
hist(Myx$titer,freq=FALSE)
curve(dgamma(x,shape=MLE$par["shape"],rate=MLE$par["rate"]),add=T,col="red")
```

Looks pretty good…

But as dangerous ecological statisticians we aren’t satisfied with using a “black box” like the “optim()” function, we need to understand what is going on behind the scenes. Let’s write our own optimizer!

We start with the conceptually simple, often computationally impossible, brute force method…

```
# BRUTE FORCE ALTERNATIVE ------------------------------
# define 2-D parameter space!
shapevec <- seq(10,100,by=0.1) # divide parameter space into tiny increments
ratevec <- seq(0.5,30,by=0.05)
# define the likelihood surface across this grid within parameter space
surface2D <- matrix(nrow=length(shapevec),ncol=length(ratevec)) # initialize storage variable
newparams <- params
for(i in 1:length(shapevec)){
newparams['shape'] <- shapevec[i]
for(j in 1:length(ratevec)){
newparams['rate'] <- ratevec[j]
surface2D[i,j] <- -1*GammaLikelihoodFunction(newparams) # compute likelihood for every point in 2-d parameter space
}
}
# Visualize the likelihood surface
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-250,-35),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-150),add=T)
```

Now what is the maximum likelihood estimate?

```
# Find the MLE (brute force) ------------------------
ndx <- which(surface2D==max(surface2D),arr.ind=T) # index of the max likelihood grid cell
shapevec[ndx[,1]]
```

`## [1] 49.5`

`ratevec[ndx[,2]]`

`## [1] 7.15`

`MLE$par # compare with the answer from "optim()"`

```
## shape rate
## 49.608753 7.164569
```

**Q** how would we compute the profile likelihood
confidence intervals for the shape and scale parameters?

If we assume that the likelihood surface is smooth (differentiable) and has only one minimum, we can use very efficient derivative-based optimization algorithms.

In general, derivative-based methods look for the point in parameter space where the first derivative (slope) of the likelihood function is zero (the ‘root’ of the likelihood function). That is, at the peak- or the valley bottom.

Let’s imagine we are interested in determining the shape parameter, given a known scale parameter for a gamma distribution. To use derivative based methods, let’s first build a function that estimates the slope of the function at any arbitrary point in parameter space:

```
# Derivative-based optimization methods ------------------
# function for estimating the slope of the likelihood surface at any point in parameter space....
## NOTE: even here I'm using a coarse, brute force method for estimating the first and second derivative of the likelihood function
params <- MLE$par
SlopeFunc <- function(shape_guess,tiny=0.001){
params['shape'] <- shape_guess
high <- GammaLikelihoodFunction(params+c(tiny,0))
low <- GammaLikelihoodFunction(params-c(tiny,0))
slope <- (high-low)/(tiny*2)
return(slope)
}
SlopeFunc(shape_guess=30) #try it!
```

`## [1] -13.75925`

Now let’s visualize this!

```
# Visualize the slope of the likelihood function at different points in parameter space
shapevec <- seq(10,100,by=0.1)
# define the likelihood surface
surface1D <- numeric(length(shapevec)) # initialize storage variable
newparams <- params
for(i in 1:length(shapevec)){
newparams['shape'] <- shapevec[i]
surface1D[i] <- GammaLikelihoodFunction(newparams)
}
plot(surface1D~shapevec,type="l")
point <- GammaLikelihoodFunction(c(shape=30,MLE$par['rate']))
slope <- SlopeFunc(shape_guess=30)
lines(c(20,40),c(point-slope*10,point+slope*10),col="red")
```

We also need a function to compute the second derivative, or the curvature (rate of change in the slope)…

```
# function for estimating the curvature of the likelihood function at any point in parameter space
params <- MLE$par
CurvatureFunc <- function(shape_guess,tiny=0.001){
params['shape'] <- shape_guess
high <- SlopeFunc(shape_guess+tiny)
low <- SlopeFunc(shape_guess-tiny)
curvature <- (high-low)/(tiny*2) # how much the slope is changing in this region of the function
return(curvature)
}
CurvatureFunc(shape_guess=30) # try it!
```

`## [1] 0.9151666`

Okay, now we can implement a derivative-based optimization algorithm!

Essentially, we are trying to find the point where the derivative of the likelihood function is zero (the root of the function!).

The simplest derivative-based optimization algorithm is the
*Newton-Raphson algorithm*. Here is the pseudocode:

- pick a guess for a parameter value

- compute the first derivative of the likelihood function for that
guess

- compute the slope of the first derivative (curvature, or second
derivative) of the likelihood function for that guess

- Extrapolate linearly to try to find the root (where the first
derivative of the likelihood function should be zero assuming the rate
of change in the slope is constant)

- repeat until the first derivative of the likelihood function is close enough to zero (within a specified tolerance), using the new value from the previous step as your initial guess.

Let’s first visualize the shape of the first derivative of the likelihood function

```
# First- visualize the gradient of the likelihood function
firstderiv <- numeric(length(shapevec)) # initialize storage variable
for(i in 1:length(shapevec)){
firstderiv[i] <- SlopeFunc(shapevec[i])
}
plot(firstderiv~shapevec,type="l")
abline(h=0,col="red")
```

Let’s use the Newton method to find the *root* of the
likelihood function. First we pick a starting value. Say we pick 80.

First compute the derivatives:

```
# Now we can perform a simple, derivative-based optimization!
### Pick "80" as the starting value
firstderiv <- SlopeFunc(80) # evaluate the first and second derivatives
secondderiv <- CurvatureFunc(80)
firstderiv
```

`## [1] 13.00653`

`secondderiv`

`## [1] 0.3396182`

Now let’s use this linear function to extrapolate to where the first derivative is equal to zero:

```
# Use this info to estimate the root
oldguess <- 80
newguess <- oldguess - firstderiv/secondderiv # estimate the root (where first deriv is zero)
newguess
```

`## [1] 41.70248`

Our new guess is that the shape parameter is 41.31. Let’s do it again!

```
# Repeat this process
oldguess <- 41.31
newguess <- oldguess - SlopeFunc(oldguess)/CurvatureFunc(oldguess)
newguess
```

`## [1] 48.86382`

Okay, we’re already getting close to our MLE of around 49.36. Let’s do it again:

```
# again...
oldguess<-newguess
newguess <- oldguess - SlopeFunc(oldguess)/CurvatureFunc(oldguess)
newguess
```

`## [1] 49.60238`

And again!

```
# again...
oldguess<-newguess
newguess <- oldguess - SlopeFunc(oldguess)/CurvatureFunc(oldguess)
newguess
```

`## [1] 49.60804`

And again!!!

```
# again...
oldguess<-newguess
newguess <- oldguess - SlopeFunc(oldguess)/CurvatureFunc(oldguess)
newguess
```

`## [1] 49.60804`

Wow, in just a few iterations we already basically found the true root. Let’s find the root for real, using an algorithm…

```
# Implement the Newton Method as a function! ------------------
NewtonMethod <- function(firstguess,tolerance=0.0000001){
deriv <- SlopeFunc(firstguess)
oldguess <- firstguess
counter <- 0
while(abs(deriv)>tolerance){
deriv <- SlopeFunc(oldguess)
newguess <- oldguess - deriv/CurvatureFunc(oldguess)
oldguess<-newguess
counter=counter+1
}
mle <- list()
mle$estimate <- newguess
mle$likelihood <- GammaLikelihoodFunction(c(shape=newguess,MLE$par['rate']))
mle$iterations <- counter
return(mle)
}
newMLE <- NewtonMethod(firstguess=80)
newMLE
```

```
## $estimate
## [1] 49.60804
##
## $likelihood
## [1] 37.66714
##
## $iterations
## [1] 6
```

In just 6 steps we successfully identified the maximum likelihood estimate to within 0.0000001 of the true value! How many computations did we have to perform to use the brute force method?

Hopefully this illustrates the power of optimization algorithms!!

Note that this method and other derivative-based methods can work in multiple dimensions! The only constraint here is that the likelihood function is differentiable (smooth)

Derivative-free methods make no assumption about smoothness. In some ways, they represent a middle ground between the brute force method and the elegant but finicky derivative-based methods- walking a delicate balance between simplicity and generality.

Derivative-free methods only require a likelihood function that returns real numbers but have no additional requirements.

This is the default optimization method for “optim()”! That means that R used this method for optimizing the fuel economy example from the previous lecture!

A *simplex* is the multi-dimensional analog of the triangle.
In a two dimensional space, the triangle is the simplest shape possible
that encloses an area. It has just one more vertex than there are
dimensions! In *n* dimensions, a simplex is defined by
*n+1* vertices.

Set up an initial simplex in parameter space, essentially representing three initial guesses about the parameter values. NOTE: when you use the Nelder-Mead algorithm in “optim()” you only specify one initial value for each free parameter. “optim()”’s internal algorithm turns that initial guess into a simplex prior to starting the Nelder-Mead algorithm.

Continue the following steps until your answer is good enough:

- Start by identifying the
*worst*vertex (the one with the lowest likelihood)

- REFLECT IT: Take the worst vertex and reflect it across the center of the shape represented by the other vertices. This is your ‘proposal vertex’. If the new likelihood at the reflected point is now the second best of all the vertices in the new simplex, then replace the old vertex with the proposal vertex.
- EXPAND IT: If the likelihood is highest for the proposal vertex (out
of all the vertices), increase the length of the jump! If this increased
jump improves the likelihood even more, replace the old vertex with this
new extended-jump vertex. If the expansion is not as good as the
reflection, use the reflected vertex instead.

- CONTRACT IT: If the original reflected vertex was bad (lower likelihood than the original) then try a point closer to the original vertex along the reflection line. If this point is better than the original vertex, replace the old vertex with this new contracted vertex.
- If all reflections, expansions and contractions were worse than the original vertex, then contract (shrink) the simplex toward the highest-likelihood vertex.

**Q**: What does the simplex look like for a
one-dimensional optimization problem?

**Q**: Is this method likely to be good at avoiding
false peaks in the likelihood surface?

**Step 1:** Set up an initial simplex in parameter
space

```
# SIMPLEX OPTIMIZATION METHOD! -----------------------
# set up an "initial" simplex
firstguess <- c(shape=70,rate=5) # "user" first guess
simplex <- list()
# set up the initial simplex based on the first guess...
simplex[['vertex1']] <- firstguess + c(3,1)
simplex[['vertex2']] <- firstguess + c(-3,-1)
simplex[['vertex3']] <- firstguess + c(3,-1)
simplex
```

```
## $vertex1
## shape rate
## 73 6
##
## $vertex2
## shape rate
## 67 4
##
## $vertex3
## shape rate
## 73 4
```

Let’s plot the simplex…

```
## first let's make a function to plot the simplex on a 2-D likelihood surface...
addSimplex <- function(simplex,col="red"){
temp <- as.data.frame(simplex) # easier to work with data frame here
points(x=temp[1,c(1,2,3,1)], y=temp[2,c(1,2,3,1)],type="b",lwd=2,col=col)
}
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-300,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-120),add=T)
addSimplex(simplex)
```

Now let’s evaluate the log likelihood at each vertex

```
# Evaluate log-likelihood at each vertex of the simplex
SimplexLik <- function(simplex){
newvec <- -1*unlist(lapply(simplex,GammaLikelihoodFunction)) # note use of apply instead of for loop...
return(newvec)
}
SimplexLik(simplex)
```

```
## vertex1 vertex2 vertex3
## -300.5682 -575.2062 -725.8400
```

Now let’s develop functions to assist our moves through parameter space, according to the rules defined above…

```
# Helper Functions
## this function reflects the worst vertex across the remaining vector
# values <- SimplexLik(simplex)
# oldsimplex=simplex[order(values,decreasing = T)] # note: must be sorted with worst vertex last
ReflectIt <- function(oldsimplex){
# vertnames <- names(oldsimplex)
n=length(oldsimplex[[1]])
centroid <- apply(t(as.data.frame(oldsimplex[1:n])),2,mean)
reflected <- centroid + (centroid - oldsimplex[[n+1]])
expanded <- centroid + 2*(centroid - oldsimplex[[n+1]])
contracted <- centroid + 0.5*(centroid - oldsimplex[[n+1]])
alternates <- list()
alternates$reflected <- oldsimplex
alternates$expanded <- oldsimplex
alternates$contracted <- oldsimplex
alternates$reflected[[n+1]] <- reflected
alternates$expanded[[n+1]] <- expanded
alternates$contracted[[n+1]] <- contracted
return(alternates)
}
# ReflectIt(oldsimplex)
ShrinkIt <- function(oldsimplex){
n <- length(oldsimplex[[1]])
X.vert <- t(as.data.frame(oldsimplex[(1:(n+1))]))
temp <- sweep(0.5*sweep(X.vert, 2, oldsimplex[[1]], FUN = "-"), 2, X.vert[1, ], FUN="+")
temp2 <- as.data.frame(t(temp))
lapply(temp2,function(t) c(shape=t[1],rate=t[2]) )
}
MoveTheSimplex <- function(oldsimplex){ # (incomplete) nelder-mead algorithm
newsimplex <- oldsimplex #
# Start by sorting the simplex (worst vertex last)
VertexLik <- SimplexLik(newsimplex)
newsimplex <- newsimplex[order(VertexLik,decreasing=T)]
liks <- VertexLik[order(VertexLik,decreasing=T)]
worstLik <- liks[3]
secondworstLik <- liks[2]
bestLik <- liks[1]
candidates <- ReflectIt(oldsimplex=newsimplex) # reflect across the remaining edge
CandidateLik <- sapply(candidates,SimplexLik) # re-evaluate likelihood at the vertices...
CandidateLik <- apply(CandidateLik,c(1,2), function(t) ifelse(is.nan(t),-99999,t))
bestCandidate <- names(which.max(CandidateLik[3,]))
bestCandidateLik <- CandidateLik[3,bestCandidate]
if((CandidateLik[3,"reflected"]<=bestLik)&(CandidateLik[3,"reflected"]>secondworstLik)){
newsimplex <- candidates[["reflected"]]
}else if (CandidateLik[3,"reflected"]>bestLik){
if(CandidateLik[3,"expanded"]>CandidateLik[3,"reflected"]){
newsimplex <- candidates[["expanded"]]
}else{
newsimplex <- candidates[["reflected"]]
}
}else{
if(CandidateLik[3,"contracted"]>worstLik){
newsimplex <- candidates[["contracted"]]
}else{
newsimplex <- ShrinkIt(newsimplex)
}
}
return(newsimplex)
}
# image(x=shapevec,y=scalevec,z=surface2D,zlim=c(-1000,-30),col=topo.colors(12))
# contour(x=shapevec,y=scalevec,z=surface2D,levels=c(-30,-40,-80,-500),add=T)
# addSimplex(oldsimplex,col="red")
# addSimplex(candidates$reflected,col="green")
# addSimplex(candidates$half,col="green")
# Visualize the simplex ---------------------
oldsimplex <- simplex
newsimplex <- MoveTheSimplex(oldsimplex)
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-125),add=T)
addSimplex(oldsimplex,col="red")
addSimplex(newsimplex,col="green")
```

Let’s try another few moves

```
# Make another move -------------
oldsimplex <- newsimplex
newsimplex <- MoveTheSimplex(oldsimplex)
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-125),add=T)
addSimplex(oldsimplex,col="red")
addSimplex(newsimplex,col="green")
```

And again!

```
# Make another move ----------------------
oldsimplex <- newsimplex
newsimplex <- MoveTheSimplex(oldsimplex)
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-125),add=T)
addSimplex(oldsimplex,col="red")
addSimplex(newsimplex,col="green")
```

Again:

```
# Make another move ----------------
oldsimplex <- newsimplex
newsimplex <- MoveTheSimplex(oldsimplex)
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-125),add=T)
addSimplex(oldsimplex,col="red")
addSimplex(newsimplex,col="green")
```

And another few times:

```
# Make another few moves ----------------------
par(mfrow=c(2,2))
for(i in 1:4){
oldsimplex <- newsimplex
newsimplex <- MoveTheSimplex(oldsimplex)
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-125),add=T)
addSimplex(oldsimplex,col="red")
addSimplex(newsimplex,col="green")
}
```

Now we can build a function and use the algorithm for optimizing!

```
# Build a simplex optimization function! -----------------
SimplexMethod <- function(firstguess,tolerance=0.00001){
initsimplex <- list()
initsimplex[['vertex1']] <- firstguess + c(5,0.5)
initsimplex[['vertex2']] <- firstguess + c(-5,-0.5)
initsimplex[['vertex3']] <- firstguess + c(5,-0.5)
VertexLik <- SimplexLik(initsimplex)
oldbestlik <- VertexLik[which.max(VertexLik)]
deltalik <- 100
counter <- 0
oldsimplex <- initsimplex
while((counter<250)&(any(abs(diff(VertexLik))>tolerance))){
newsimplex <- MoveTheSimplex(oldsimplex)
VertexLik <- SimplexLik(newsimplex)
bestlik <- VertexLik[which.max(VertexLik)]
oldsimplex <- newsimplex
counter <- counter+1
}
mle <- list()
mle$estimate <- newsimplex[[1]]
mle$likelihood <- bestlik
mle$iterations <- counter
return(mle)
}
SimplexMethod(firstguess = c(shape=39,rate=4))
```

```
## $estimate
## shape rate
## 49.656948 7.172449
##
## $likelihood
## vertex3
## -37.66714
##
## $iterations
## [1] 41
```

I like to call this the “amoeba” method of optimization!

In general, the simplex-based methods are less efficient than the derivative-based methods at finding the MLE- especially as you near the MLE.

Simulated annealing is one of my favorite optimization techniques. I think it serves as a good metaphor for problem-solving in general. When solving a problem, the first step is to think big, try to imagine whether we might be missing possible solutions. Then we settle (focus) on a general solution, learn more about how that solution applies to our problem, and ultimately get it done!

The temperature analogy is fun too! We start out “hot”- unfocused, frenzied, bouncing around - and we end up “cold” - crystal clear and focused on a solution!

Simulated annealing is called a “global” optimization solution because it can deal with false peaks and other strangenesses that can arise in optimization problems (e.g., maximizing likelihood). The price is in reduced efficiency!

Pick an initial starting point and evaluate the likelihood.

Continue the following steps until your answer is good enough:

- Pick a new point at random near your old point and compute the (log) likelihood

- If the new value is better, accept it and start again

- If the new value is worse, then

- Pick a random number between zero and 1

- Accept the new (worse) value anyway if the random number is less than exp(change in log likelihood/k). Otherwise, go back to the previous value

- Periodically (e.g. every 100 iterations) lower the value of
kto make it harder to accept bad moves. Eventually, the algorithm will “settle down” on a particular point in parameter space.

A simulated annealing method is available in the “optim” function in R (method = “SANN”)

Let’s use the same familiar myxomatosis example!

```
# Simulated annealing! -----------------------
startingvals <- c(shape=80,rate=7)
startinglik <- -GammaLikelihoodFunction(startingvals)
startinglik
```

`## [1] -270.5487`

```
k = 100 # set the "temperature"
# function for making new guesses
newGuess <- function(oldguess=startingvals){
maxshapejump <- 5
maxratejump <- 0.75
jump <- c(runif(1,-maxshapejump,maxshapejump),runif(1,-maxratejump,maxratejump))
newguess <- oldguess + jump
return(newguess)
}
# set a new "guess" near to the original guess
newGuess(oldguess=startingvals) # each time is different- this is the first optimization procedure with randomness built in
```

```
## shape rate
## 76.416983 7.329611
```

`newGuess(oldguess=startingvals)`

```
## shape rate
## 80.837027 7.247608
```

`newGuess(oldguess=startingvals)`

```
## shape rate
## 76.552051 7.611385
```

Now let’s evaluate the difference in likelihood between the old and the new guess…

```
# evaluate the difference in likelihood between the new proposal and the old point
LikDif <- function(oldguess,newguess){
oldLik <- -GammaLikelihoodFunction(oldguess)
newLik <- -GammaLikelihoodFunction(newguess)
return(newLik-oldLik)
}
newguess <- newGuess(oldguess=startingvals)
loglikdif <- LikDif(oldguess=startingvals,newguess)
loglikdif
```

`## [1] -103.0489`

Now let’s look at the Metropolis routine:

```
# run and visualize a Metropolis simulated annealing routine -------------
k <- 100
oldguess <- startingvals
counter <- 0
guesses <- matrix(0,nrow=100,ncol=2)
colnames(guesses) <- names(startingvals)
while(counter<100){
newguess <- newGuess(oldguess)
loglikdif <- LikDif(oldguess,newguess)
if(loglikdif>0){
oldguess <- newguess
}else{
rand=runif(1)
if(rand <= exp(loglikdif/k)){
oldguess <- newguess # accept even if worse!
}
}
counter <- counter + 1
guesses[counter,] <- oldguess
}
# visualize!
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-135),add=T)
lines(guesses,col="red")
```

Clearly this is the most inefficient, brute-force method we have seen so far (aside from the actual brute force method). And also quite clearly, in the context of this class, the best and most fun (and dangerous?!).

NOTE: simulated annealing is still way more efficient than the brute force method we saw earlier, especially with multiple dimensions!

Let’s run it for longer, and with a smaller value of k..

```
# Run it for longer!
k <- 10
oldguess <- startingvals
counter <- 0
guesses <- matrix(0,nrow=1000,ncol=2)
colnames(guesses) <- names(startingvals)
while(counter<1000){
newguess <- newGuess(oldguess)
while(any(newguess<0)) newguess <- newGuess(oldguess)
loglikdif <- LikDif(oldguess,newguess)
if(loglikdif>0){
oldguess <- newguess
}else{
rand=runif(1)
if(rand <= exp(loglikdif/k)){
oldguess <- newguess # accept even if worse!
}
}
counter <- counter + 1
guesses[counter,] <- oldguess
}
# visualize!
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-135),add=T)
lines(guesses,col="red")
```

This looks better! The search algorithm is finding the high-likelihood parts of parameter space pretty well!

Now let’s “cool” the temperature over time, let the algorithm settle down on a likelihood peak

```
# cool the "temperature" over time and let the algorithm settle down
k <- 100
oldguess <- startingvals
counter <- 0
guesses <- matrix(0,nrow=10000,ncol=2)
colnames(guesses) <- names(startingvals)
MLE <- list(vals=startingvals,lik=-GammaLikelihoodFunction(startingvals),step=0)
while(counter<10000){
newguess <- newGuess(oldguess)
while(any(newguess<0)) newguess <- newGuess(oldguess)
loglikdif <- LikDif(oldguess,newguess)
if(loglikdif>0){
oldguess <- newguess
}else{
rand=runif(1)
if(rand <= exp(loglikdif/k)){
oldguess <- newguess # accept even if worse!
}
}
counter <- counter + 1
if(counter%%100==0) k <- k*0.8
guesses[counter,] <- oldguess
thislik <- -GammaLikelihoodFunction(oldguess)
if(thislik>MLE$lik) MLE <- list(vals=oldguess,lik=-GammaLikelihoodFunction(oldguess),step=counter)
}
# visualize!
image(x=shapevec,y=ratevec,z=surface2D,zlim=c(-500,-30),col=topo.colors(12))
contour(x=shapevec,y=ratevec,z=surface2D,levels=c(-30,-40,-80,-135),add=T)
lines(guesses,col="red")
points(MLE$vals[1],MLE$vals[2],col="green",pch=20,cex=3)
```

`MLE`

```
## $vals
## shape rate
## 49.914729 7.206274
##
## $lik
## [1] -37.66748
##
## $step
## [1] 5777
```

`optim(params,GammaLikelihoodFunction)$par`

```
## shape rate
## 49.608753 7.164569
```

As you can see, the simulated annealing method did pretty well. However, we needed thousands of iterations to do what other methods just take a few iterations to do. But, we might feel better that we have explored parameter space more thoroughly and avoided the potential problem of false peaks (although there’s no guarantee that the simulated annealing method will find the true MLE).

As you can see, there are many ways to optimize- and the
*optimal* optimization routine is not always obvious!

You can probably use some creative thinking and imagine your own optimization algorithm… For example, some have suggested combining the simplex method with the simulated annealing method! Optimization is an art!!

As you can see in the previous examples, most of the optimization techniques we have looked at do not explore parameter space enough to discern the shape of the likelihood surface around the maximum likelihood estimate. Therefore, we do not have the information we need to compute the confidence intervals around our parameter estimates. And what good is a point estimate without a corresponding estimate of uncertainty??

There are several techniques that are widely used to estimate and describe parameter uncertainty:

- Brute force (expose the entire likelihood surface!) [okay, this one isn’t actually used very often]
- Profile likelihood (the most accurate way!)
- Evaluate curvature at the MLE and use that to estimate sampling error (somewhat inexact but efficient- but generally performs pretty well, and is the default for many MLE routines!)