# R/backtrack.R In patperry/r-mbest: Moment-Based Estimation for Hierarchical Models

```# Copyright 2014 Patrick O. Perry
#
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#
# Unless required by applicable law or agreed to in writing, software
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and

# Perform a one-dimensional backtracking line search to find a step length
# satisfying the Armijo condition (sufficient decrease).
#
# References:
#
# * Nocedal, J. and Wright, S. J. (2006). /Numerical Optimization/, 2nd ed.
#   Springer.
#   <http://www.springer.com/mathematics/book/978-0-387-30303-1>
#

# default search parameters
backtrack.control <- function(value.tol = 1e-4, contract = 0.5,
step.min = 1e-10)
{
if (!is.numeric(value.tol) || value.tol <= 0)
stop("value of 'value.tol' must be > 0")
if (!is.numeric(contract) || !(0 < contract && contract < 1))
stop("value  of 'contract' must be in (0,1)")
if (!is.numeric(step.min) || step.min <= 0)
stop("value of 'step.min' must be > 0")

list(value.tol = value.tol, contract = contract, step.min = step.min)
}

# Start a line search, given initial value, derivative and step size.
# Return value includes fields `step` giving next step to true, and
# `converged` indicating whether or not search has converged.
backtrack <- function(value, deriv, step, control = list())
{
control <- do.call("backtrack.control", control)

if (!is.numeric(value) || is.na(value))
stop("missing initial value")
if (!is.numeric(deriv) || is.na(deriv))
stop("missing initial derivative")
if (!(deriv < 0 && is.finite(deriv)))
stop("initial derivative must be negative and finite")
if (!(control\$step.min < step))
stop("initial step must be > step.min")

gtest <- deriv * control\$value.tol
ftest <- value + step * gtest
best <- list(position = 0, value = value, deriv = deriv)

z <- list(step = step, value0 = value, deriv0 = deriv, ftest = ftest,
gtest = gtest, best = best, converged = FALSE, control=control)
class(z) <- "backtrack"
z
}

print.backtrack <- function(x, digits = max(3L, getOption("digits") - 3L), ...)
{
if (x\$converged) {
cat("Converged backtracking linesearch (step = ",
format(x\$step, digits), ")\n", sep="")
} else {
cat("Backtracking linesearch in progress; next step = ",
format(x\$step, digits), "\n", sep="")
}
}

# update search with new value and derivative
update.backtrack <- function(object, value, deriv, ...)
{
control <- object\$control
ftest <- object\$ftest
gtest <- object\$gtest
step <- object\$step

converged <- FALSE
stuck <- FALSE

if (is.na(value))
stop("function value is NA")
if (is.na(deriv))
stop("function derivative is NA")

test <- list(position = object\$step, value = value, deriv = deriv)
if (object\$best\$value > value)
object\$best <- test

if (value <= ftest) {
converged <- TRUE
} else if (step == control\$step.min) {
warning("at step.min")
stuck <- TRUE
}

if (converged || stuck) {
object\$converged <- converged
object\$value <- value
object\$deriv <- deriv
return(object)
}

update.backtrack.step(object, test)
}

update.backtrack.step <- function(object, test)
{
control <- object\$control

# compute new trial step
step <- (test\$position) * (control\$contract)

# safeguard the step
step <- max(control\$step.min, step)

object\$ftest <- object\$value0 + step * (object\$gtest)
object\$step <- step

object
}
```
patperry/r-mbest documentation built on May 25, 2018, 11:40 p.m.