I am trying to set up an optimization with the constraint: sum(abs(x-y))*0.5 where x are my decision variables and y are given inputs.
x <- c(0.25, 0.3, 0.05, 0.25, 0.15)
y <- rep(0.2, 5)
I have added the function
AcS <- function(g, h, dir, rhs) {
AS <- sum(abs(g-h))*0.5
return(AS)
L_constraint(L = L, dir = dir, rhs = rhs)
}
And then with the ROI package attempted to create the constraint as: AcS_cons <- L_constraint(AcS(x, y), "<=", 0.25)
With
c1 <- c(1:24, -25)
C <- matrix(c1,nrow=5,ncol=5,byrow=TRUE)
I then have my optimization problem setup to solve for x as:
QPL <- OP(Q_objective(Q = C, L = rep(0, NCOL(count_y))),
act_share_2,
max = FALSE)
When i run this I get the following error: Error in .check_constraints.L_constraint(constr, x) :
dimension missmatch! OP has 5 variables the constraints have 1
Any help on how to adjust the above, or how to setup a constraint for my function AcS would be appreciated.
Related
I need to find the value of a parameter which make my function produce a specific result.
I write down something like this:
## Defining the function
f = function(a, b, c, x) sqrt(t(c(a, b, c, x)) %*% rho %*% c(a, b, c, x))
## Set di input needed
rho <- matrix(c(1,0.3,0.2,0.4,
0.3,1,0.1,0.1,
0.2,0.1,1,0.5,
0.4,0.1,0.5,1),
nrow = 4, ncol = 4)
target <- 10000
## Optimize
output <- optimize(f, c(0, target), tol = 0.0001, a = 1000, b = 1000, c = 1000, maximum = TRUE)
I would like to derive di value of x related to the maximum of my function (the target value).
Thanks,
Ric
You can find one such x with closed formula. For symmetric matrices (like the one you have) you can achieve target value by vector x where x is defined as:
spectral_decomp <- eigen(rho, TRUE)
eigen_vec1 <- spectral_decomp$vectors[,1]
lambda1 <- spectral_decomp$values[[1]]
target <- 1000
x <- (target / sqrt(lambda1)) * eigen_vec1
check:
sqrt(matrix(x, nrow = 1) %*% rho %*% matrix(x, ncol = 1))
I want to run a function over a vector, using the lapply() command. This is my attempt, reproducible:
set.seed(10101)
# define parameters
N <- 1000
a <- 0.3
# create vector of variables
e <- rnorm(N)
l <- rchisq(N, df = 3, ncp = 0)
k <- rbeta(N, shape1 = 2, shape2 = 5, ncp = 0)
# vector over which to run function
g <- c(1, 0.5, 0.3, 0.1, -0.2, -0.5, -1)
# define function
CES <- function(g,a,e){
exp(e)*(a*l^g+(1-a)*k^g)^(1/g)
}
# result
y <- lapply(g,CES)
I get the error
Error in FUN(X[[i]], ...) : argument "e" is missing, with no default
What is the mistake? Is it due to the fact that the elements of the function (l,k,e) are themselves vectors?
You have to do
y <- lapply(g, CES, a=a, e=e)
It is to follow the description of the error. The parameters a= and e= of your function CES() have no default - so you have to deliver them to the function. You can use the ...-argument of the function lapply() to do that.
Alternativly (see the comment from #Cath) you can change the definition of your function:
CES <- function(g, a=a, e=e) exp(e)*(a*l^g+(1-a)*k^g)^(1/g)
y <- lapply(g, CES) # now works
or (a bad variant):
CES <- function(g) exp(e)*(a*l^g+(1-a)*k^g)^(1/g)
y <- lapply(g, CES) # now works
So, I have these functions:
funk1 <- function(a,x,l,r) {
x^2*exp(-(l*(1-exp(-r*a))/r))}
funk2 <- function(x,l,r) {
sapply(x, function (s) {
integrate(funk1, lower = 0, upper = s, x=s, l=l, r=r)$value })}
which are used to explain the data y in,
z <- data.frame(ts = 1:100,
y = funk2(1:100, l = 1, r = 1) + rpois(100, 1:100))
I wish to use optim to maximise the likelihood, so I defined a likelihood function:
LL_funk <- function(l,r) {
n=nrow(z)
R = sum((funk2(ts,l,r) - y)^2)
logl = -((n/2)*log(R))
return(-logl)
}
and I tried to fit using optim
fit <- optim(par=c(0.5,0.5), fn= LL_funk, method="Nelder-Mead")
But I get an error:
Error in integrate(funk1, lower = 0, upper = s, x = s, l = l, r = r) :
a limit is missing
I am not sure why? I could run nls fitting funk2(x,l,r) to y
nls(y ~ funk2(ts,l,r), data = z, start = list(l = 0.5, r = 0.5))
That means funk2 is working. I guess its the problem with LL function that I have designed, which I cant figure out!! Please Help!
Yup! There were two problems with your function. This worked for me:
LL_funk <- function(params) {
n=nrow(z)
l = params[1]
r = params[2]
R = sum((funk2(z$ts,l,r) - z$y)^2)
logl = -((n/2)*log(R))
return(-logl)
}
Previous issues:
LL_funk only takes 1 argument, which is the vector of parameters.
In LHS of the assignment of R, ts and y were not actually referring to columns in your dataset.
Any help with this would be greatly appreciated. I am optimising parameters of a lognormal distribution so that the proportion of estimates matches a set of target values (distances). The proportions are calculated using the following functions:
adj_sumifs <- function(sum_array, condition_array, f, m=1){
n <- length(condition_array)
sm = 0
if (n == length(condition_array)){
fun <- function(x,i){if (f (condition_array[i])){sum_array[i] + x}else{x} }
sm <- Reduce(fun,1:n,0)
}
ifelse(m <= 0, sm , sm/m)
}
and
estimate.inrange <- function(vals,dist,lower,upper,total){
n <- length(lower)
if (n == length(upper)){
sapply(1:n, function(i){ ifelse(i < n ,
adj_sumifs(vals,dist, (function(x) x >= lower[i] && x < upper[i]),total) ,
adj_sumifs(vals,dist, (function(x) x >= lower[i]) , total)
) }
)
}else{
# for a failure in the process
as.numeric()
}
}
And the function I would like to optimise is:
calculate_Det_ptns <- function(alpha, beta, pxa, low,up, distances, eF){
temp <- numeric()
if ( length(pxa) == length(distances) && length(low) == length(up) )
{
ln_values <- as.numeric(Map(function(pa,d) eF * pa * dlnorm(d, meanlog = alpha, sdlog = beta),pxa,distances))
temp <- estimate.inrange (ln_values,distances,low,up, total = sum(ln_values))
}
temp
}
Optimisation is done using the Levenberg-Marquardt algorithm
lnVals <- nlsLM(target ~ calculate_Det_ptns(alpha = a,beta = b, pxa = odab,low = low, up = up, distances = dist, eF = expF),
start = list(a = mu, b = sd ),
trace = T)
where up,low and target are extracted from the same data file, e,g,
low, up, target
1,2,0.1
2,3,0.4
3,4,0.6
4,5,0.6
5,6,0.9
while odab and distance are vectors of arbitrary lengths (usually much longer than target,etc). The process works well when the target file has anout 150 rows, and distances and odab have about 500000 values. However, for reasons I cannot fathom, is fails when the target file has about 16 rows. The error message is:
Error in model.frame.default(formula = ~target + odab + low + up + dist) :
variable lengths differ (found for 'odab')
which suggests that the function is not being evaluated in the formula. Can anyone suggest a solution or explanation? It is important that the proportions are re-estimated for every new mu and sd.
You could try surrounding the function with I(), which will evaluate it as is before evaluating the formula; however, I could not replicate your problem with the code provided because I am missing some of the referenced objects (a, b, odab, dist, expF, mu, sd) so I could not confirm whether or not this works.
nVals <- nlsLM(target ~ I(calculate_Det_ptns(alpha = a,beta = b, pxa = odab,low = low, up = up, distances = dist, eF = expF)), start = list(a = mu, b = sd ), trace = T)
I was playing around with the nlsLM function, from the minpack.lm library, and encountered some behaviour that I don't understand.
Given that the following function produces output when I supply a numeric vector 'b' as input I wanted to use this function to fit a nonlinear model to my data.
volEquation <- function(DBH, PHt, b){
b[1] * DBH^b[2] * PHt^b[3]
}
However I have become stuck when it comes to correctly specifying the initial parameter values. R code follows:
library(minpack.lm)
n <- 20
x <- seq(12, 60, length.out = n)
y <- seq(22, 45, length.out = n)
z <- x^2 * y ^ 3 + rnorm(n, 0, 0.1)
Data <- data.frame(DBH = x, PHt = y, TVT = z)
nlsFormula <- "TVT ~ volEquation(DBH, PHt, b)"
nlsInitial <- list(b = c(0.5, 2.25, 3.25))
nlsLMOutput <- nlsLM(formula = nlsFormula, data = Data, start = nlsInitial)
nlsOutput <- nls(formula = nlsFormula, data = Data, start = nlsInitial
nls was successful at fitting the data while nlsLM gave me this error message,
Error in rownames<-(*tmp*, value = "b") :
length of 'dimnames' [1] not equal to array extent
Can anyone provide insight as to why this problem occurs in the nlsLM function? I've tried sifting through the nlsLM code but I still don't understand what's going on.
Try separating your parameters
volEquation <- function(DBH, PHt, x,y,z){
x * DBH^y * PHt^z
}
nlsFormula <- "TVT ~ volEquation(DBH, PHt, x, y, z)"
nlsInitial <- c(x=5e-3, y=2, z=1)
nlsOutput <- nlsLM(formula = nlsFormula, data = Data, start = nlsInitial, control=nls.lm.control(maxiter=100))