Passing multiple starting values to nlminb - r

I've tried do.call and apply, and there was a similar nlminb answer that used the plyr package but still no good. So I turn to you all for any suggestions.
I've created the following function:
calloptim <- function( under,strike, rf, ttoe,par) {(-(under*par[1]
-strike*exp(-rf*ttoe)*par[2]))^2}
and then used nlminb to estimate par while holding the other arguments constant:
nlminb(c(2,2), calloptim, under= 90, strike = 100, rf =0.05, ttoe=3)
which yields:
$par
[1] 1.953851 2.043045
$objective
[1] 1.335531e-17
$convergence
[1] 0
$iterations
[1] 4
$evaluations
function gradient
6 10
$message
[1] "X-convergence (3)"
when I put in another starting value, for example
nlminb(c(5,5), calloptim, under= 90, strike = 100, rf =0.05, ttoe=3)
I get different estimates:
$par
[1] 4.885987 5.109036
$objective
[1] 2.464145e-14
$convergence
[1] 1
$iterations
[1] 2
$evaluations
function gradient
33 4
$message
[1] "false convergence (8)"
And thats ok! I understand mathematically what's happening. In fact I want to use different starting values.
My problem arises when I try to pass multiple starting values to nlminb.
I create a matrix:
f<- c(2,5,2,5)
dim(f) <- c(2,2)
> f
[,1] [,2]
[1,] 2 2
[2,] 5 5
But when I pass f to nlminb's starting value
nlminb(f, calloptim, under= 90, strike = 100, rf =0.05, ttoe=3)
I get:
$par
[1] 3.452902 3.610530 2.000000 5.000000
$objective
[1] 3.010198e-19
$convergence
[1] 0
$iterations
[1] 4
$evaluations
function gradient
22 24
$message
[1] "X-convergence (3)"
So my question is how can I pass multiple rows of starting values to nlminb?
Thanks for any suggestions!
Rye

Since ?nlminb says its first argument should be a numeric vector, you need apply it to each row of your matrix f.
out <- apply(f, 1, nlminb, objective=calloptim, under=90, strike=100, rf=0.05, ttoe=3)
str(out)
List of 2
$ :List of 6
..$ par : num [1:2] 1.95 2.04
..$ objective : num 1.34e-17
..$ convergence: int 0
..$ iterations : int 4
..$ evaluations: Named int [1:2] 6 10
.. ..- attr(*, "names")= chr [1:2] "function" "gradient"
..$ message : chr "X-convergence (3)"
$ :List of 6
..$ par : num [1:2] 4.89 5.11
..$ objective : num 2.46e-14
..$ convergence: int 1
..$ iterations : int 2
..$ evaluations: Named int [1:2] 33 4
.. ..- attr(*, "names")= chr [1:2] "function" "gradient"
..$ message : chr "false convergence (8)"

Related

Optimization in R with constraint on the sum and type of optimization parameters

I have written a function below that I would like to optimize
my_function = function(param, q, m){
out = sum(-param*q + param*m)
return(-out)
}
I am able to run the function and obtain an optimized result
> init = c(0,0,0)
> q = c(0.6, 0.14, 0.18)
> m = c(0, 2.5 , 4.2)
>
> nlminb(init, my_function, q=q, m=m, lower=c(0,0,0), upper=c(3,3,3))
$par
[1] 0 3 3
$objective
[1] -19.14
$convergence
[1] 0
$iterations
[1] 3
$evaluations
function gradient
4 9
$message
[1] "both X-convergence and relative convergence (5)"
I would like to introduce the following constraints but I'm not sure how to do this
The output parameters should be non-negative integers
The parameters should sum up to some value k
Can someone inform me on how I can achieve this please?
1) Define a function proj such that for any input vector x
the output vector y satisfies sum(y) = k. Then we have the following.
Note that this is a relaxation of the original problem where we have not applied the integer constraint; however, if the relaxed problem satisfies the constraint then it must be the solution to the original problem as well.
proj <- function(x, k = 3) k * x / sum(x)
obj <- function(x, ...) my_function(proj(x), ...)
out <- nlminb(c(1, 1, 1), obj, q = q, m = m, lower = 0)
str(out)
## List of 6
## $ par : num [1:3] 0 0 5.05
## $ objective : num -12.1
## $ convergence: int 0
## $ iterations : int 4
## $ evaluations: Named int [1:2] 5 12
## ..- attr(*, "names")= chr [1:2] "function" "gradient"
## $ message : chr "both X-convergence and relative convergence (5)"
proj(out$par) # solution
## [1] 0 0 3
2) Another approach is to use integer programming. This one does explicitly impose the integer constraint.
library(lpSolve)
res <- lp("min", q-m, t(rep(1, 3)), "=", 3, all.int = TRUE)
str(res)
giving the following (res$solution is the solution).
List of 28
$ direction : int 0
$ x.count : int 3
$ objective : num [1:3] 0.6 -2.36 -4.02
$ const.count : int 1
$ constraints : num [1:5, 1] 1 1 1 3 3
..- attr(*, "dimnames")=List of 2
.. ..$ : chr [1:5] "" "" "" "const.dir.num" ...
.. ..$ : NULL
$ int.count : int 3
$ int.vec : int [1:3] 1 2 3
$ bin.count : int 0
$ binary.vec : int 0
$ num.bin.solns : int 1
$ objval : num -12.1
$ solution : num [1:3] 0 0 3
$ presolve : int 0
$ compute.sens : int 0
$ sens.coef.from : num 0
$ sens.coef.to : num 0
$ duals : num 0
$ duals.from : num 0
$ duals.to : num 0
$ scale : int 196
$ use.dense : int 0
$ dense.col : int 0
$ dense.val : num 0
$ dense.const.nrow: int 0
$ dense.ctr : num 0
$ use.rw : int 0
$ tmp : chr "Nobody will ever look at this"
$ status : int 0
- attr(*, "class")= chr "lp"
You could try a brute-force grid search:
my_function <- function(param, q, m){
out <- sum(-param*q + param*m)
-out
}
q <- c(0.6, 0.14, 0.18)
m <- c(0, 2.5 , 4.2)
library("NMOF")
ans <- gridSearch(fun = my_function,
lower = c(0, 0, 0),
upper = c(3, 3, 3),
n = 4, ## 4 levels from lower to upper: 0,1,2,3
q = q, m = m)
The answer is a list of all the possible combinations and their objective-function values:
ans
## $minfun
## [1] -19.14
##
## $minlevels
## [1] 0 3 3
##
## $values
## [1] 0.00 0.60 1.20 1.80 -2.36 -1.76 -1.16 -0.56 -4.72 -4.12
## [11] -3.52 -2.92 -7.08 -6.48 -5.88 -5.28 -4.02 -3.42 -2.82 -2.22
## [21] -6.38 -5.78 -5.18 -4.58 -8.74 -8.14 -7.54 -6.94 -11.10 -10.50
## [31] -9.90 -9.30 -8.04 -7.44 -6.84 -6.24 -10.40 -9.80 -9.20 -8.60
## [41] -12.76 -12.16 -11.56 -10.96 -15.12 -14.52 -13.92 -13.32 -12.06 -11.46
## [51] -10.86 -10.26 -14.42 -13.82 -13.22 -12.62 -16.78 -16.18 -15.58 -14.98
## [61] -19.14 -18.54 -17.94 -17.34
##
## $levels
## $levels[[1]]
## [1] 0 0 0
##
## $levels[[2]]
## [1] 1 0 0
##
## $levels[[3]]
## [1] 2 0 0
##
## .....
##
## $levels[[64]]
## [1] 3 3 3
The levels are non-negative integers, but their sum is unconstrained. To add a sum constraint, either check in the objective function and return a large value if the particular solution violates the constraint (i.e. the solution gets marked as bad). Or filter the results; for instance, suppose the sum should be 2:
valid <- sapply(ans$levels, sum) == 2
ans$values[valid]
## [1] 1.20 -1.76 -4.72 -3.42 -6.38 -8.04
ans$levels[valid]
## [[1]]
## [1] 2 0 0
##
## [[2]]
## [1] 1 1 0
##
## [[3]]
## [1] 0 2 0
##
## [[4]]
## [1] 1 0 1
##
## [[5]]
## [1] 0 1 1
##
## [[6]]
## [1] 0 0 2
Then keep only the best of the valid solutions.
best <- which.min(ans$values[valid])
ans$values[valid][best]
## [1] -8.04
ans$levels[valid][best]
## [[1]]
## [1] 0 0 2

R - How to extract slope and intercept from lm.fit?

I need a faster way of doing linear regression than the lm() method. I found that lm.fit() is quite a bit faster but I'm wondering how to use the results. For example using this code:
x = 1:5
y = 5:1
regr = lm.fit(as.matrix(x), y)
str(regr)
Outputs:
List of 8
$ coefficients : Named num 0.636
..- attr(*, "names")= chr "x1"
$ residuals : num [1:5] 4.364 2.727 1.091 -0.545 -2.182
$ effects : Named num [1:5] -4.719 1.69 -0.465 -2.619 -4.774
..- attr(*, "names")= chr [1:5] "x1" "" "" "" ...
$ rank : int 1
$ fitted.values: num [1:5] 0.636 1.273 1.909 2.545 3.182
$ assign : NULL
$ qr :List of 5
..$ qr : num [1:5, 1] -7.416 0.27 0.405 0.539 0.674
..$ qraux: num 1.13
..$ pivot: int 1
..$ tol : num 1e-07
..$ rank : int 1
..- attr(*, "class")= chr "qr"
$ df.residual : int 4
I'm expecting intercept = 6 and slope = -1 but the result above doesn't contain anyhing near that. Also, does lm.fit() output r squared?
lm.fit allows to do things much more manually, so, as #MrFlick commented, we must include the intercept manually as well using cbind(1, x) as the design matrix. The R^2 is not provided but we may easily compute it:
x <- 1:5
y <- 5:1 + rnorm(5)
regr <- lm.fit(cbind(1, x), y)
regr$coef
# x
# 5.2044349 -0.5535963
1 - var(regr$residuals) / var(y) # R^2
# [1] 0.3557227
1 - var(regr$residuals) / var(y) * (length(y) - 1) / regr$df.residual # Adj. R^2
# [1] 0.1409636

lm(): What is qraux returned by QR decomposition in LINPACK / LAPACK

rich.main3 is a linear model in R. I understand the rest of the elements of the list but I don't get what qraux is. The documentation states that it is
a vector of length ncol(x) which contains additional information on \bold{Q}".
What additional information does it mean?
str(rich.main3$qr)
qr : num [1:164, 1:147] -12.8062 0.0781 0.0781 0.0781 0.0781 ...
..- attr(*, "dimnames")=List of 2
.. ..$ : chr [1:164] "1" "2" "3" "4" ...
.. ..$ : chr [1:147] "(Intercept)" "S2" "S3" "x1" ...
..- attr(*, "assign")= int [1:147] 0 1 1 2 3 4 5 6 7 8 ...
..- attr(*, "contrasts")=List of 3
.. ..$ S : chr "contr.treatment"
.. ..$ ID : chr "contr.treatment"
.. ..$ Block: chr "contr.treatment"
$ qraux: num [1:147] 1.08 1.06 1.16 1.21 1.27 ...
$ pivot: int [1:147] 1 2 3 4 5 6 7 8 10 11 ...
$ tol : num 1e-07
$ rank : int 21
- attr(*, "class")= chr "qr"
Presumably you don't know how QR factorization is computed. I wrote the following in LaTeX which might help you clarify this. Surely on a programming site I need to show you some code. In the end I offer you a toy R function computing Householder reflection.
Householder reflection matrix
Householder transformation
Householder QR factorization (without pivoting)
Compact storage of QR and rescaling
The LAPACK auxiliary routine dlarfg is performing Householder transform. I have also written the following toy R function for demonstration:
dlarfg <- function (x) {
beta <- -1 * sign(x[1]) * sqrt(as.numeric(crossprod(x)))
v <- c(1, x[-1] / (x[1] - beta))
tau <- 1 - x[1] / beta
y <- c(beta, rep(0, length(x)-1L))
packed_yv <- c(beta, v[-1])
oo <- cbind(x, y, v, packed_yv)
attr(oo, "tau") <- tau
oo
}
Suppose we have an input vector
set.seed(0); x <- rnorm(5)
my function gives:
dlarfg(x)
# x y v packed_yv
#[1,] 1.2629543 -2.293655 1.00000000 -2.29365466
#[2,] -0.3262334 0.000000 -0.09172596 -0.09172596
#[3,] 1.3297993 0.000000 0.37389527 0.37389527
#[4,] 1.2724293 0.000000 0.35776475 0.35776475
#[5,] 0.4146414 0.000000 0.11658336 0.11658336
#attr(,"tau")
#[1] 1.55063

Trying to get subset but showing error : (list) object cannot be coerced to type 'double'

I tried to find the subset but it's showing error as :
I am performing Data Envelopment Analysis using Benchmarking Package in R.
Although I saw similar Question were asked before but it didn't help me .
Update :Structure and Summary of Database
I am performing DEA for V6 and V7.
I guess you need
Large.Cap$V1[e_crs$eff > 0.85]
Using a reproducible example from ?dea
library(Benchmarking)
x <- matrix(c(100,200,300,500,100,200,600),ncol=1)
y <- matrix(c(75,100,300,400,25,50,400),ncol=1)
Large.Cap <- data.frame(v1= LETTERS[1:7], v2= 1:7)
e_crs <- dea(x, y, RTS='crs', ORIENTATION='in')
e_crs
#[1] 0.7500 0.5000 1.0000 0.8000 0.2500 0.2500 0.6667
The e_crs object is a list
str(e_crs)
#List of 12
# $ eff : num [1:7] 0.75 0.5 1 0.8 0.25 ...
# $ lambda : num [1:7, 1:7] 0 0 0 0 0 0 0 0 0 0 ...
# ..- attr(*, "dimnames")=List of 2
# .. ..$ : NULL
# .. ..$ : chr [1:7] "L1" "L2" "L3" "L4" ...
# $ objval : num [1:7] 0.75 0.5 1 0.8 0.25 ...
# $ RTS : chr "crs"
# $ primal : NULL
# $ dual : NULL
# $ ux : NULL
# $ vy : NULL
# $ gamma :function (x)
# $ ORIENTATION: chr "in"
# $ TRANSPOSE : logi FALSE
# $ param : NULL
# - attr(*, "class")= chr "Farrell"
We extract the 'eff' list element from 'e_crs' to subset the 'v1' column in 'Large.Cap' dataset.
droplevels(Large.Cap$v1[e_crs$eff > 0.85])
#[1] C
#Levels: C

How to get fitted values from ar() method model in R

I want to retrieve the fitted values from an ar() function output model in R. When using Arima() method, I get them using fitted(model.object) function, but I cannot find its equivalent for ar().
It does not store a fitted vector but does have the residuals. An example of using the residuals from the ar-object to reconstruct the predictions from the original data:
data(WWWusage)
arf <- ar(WWWusage)
str(arf)
#====================
List of 14
$ order : int 3
$ ar : num [1:3] 1.175 -0.0788 -0.1544
$ var.pred : num 117
$ x.mean : num 137
$ aic : Named num [1:21] 258.822 5.787 0.413 0 0.545 ...
..- attr(*, "names")= chr [1:21] "0" "1" "2" "3" ...
$ n.used : int 100
$ order.max : num 20
$ partialacf : num [1:20, 1, 1] 0.9602 -0.2666 -0.1544 -0.1202 -0.0715 ...
$ resid : Time-Series [1:100] from 1 to 100: NA NA NA -2.65 -4.19 ...
$ method : chr "Yule-Walker"
$ series : chr "WWWusage"
$ frequency : num 1
$ call : language ar(x = WWWusage)
$ asy.var.coef: num [1:3, 1:3] 0.01017 -0.01237 0.00271 -0.01237 0.02449 ...
- attr(*, "class")= chr "ar"
#===================
str(WWWusage)
# Time-Series [1:100] from 1 to 100: 88 84 85 85 84 85 83 85 88 89 ...
png(); plot(WWWusage)
lines(seq(WWWusage),WWWusage - arf$resid, col="red"); dev.off()
The simplest way to get the fits from an AR(p) model would be to use auto.arima() from the forecast package, which does have a fitted() method. If you really want a pure AR model, you can constrain the differencing via the d parameter and the MA order via the max.q parameter.
> library(forecast)
> fitted(auto.arima(WWWusage,d=0,max.q=0))
Time Series:
Start = 1
End = 100
Frequency = 1
[1] 91.68778 86.20842 82.13922 87.60576 ...

Resources