The overview of the problem is as follows:
Given observed data x(1)....x(n) and a known fixed 'target' T with tolerance E, solve for parameters b0, b1, & b2, which satisfy:
abs{ T - sum[i=1 to n] exp(b0+b1x(i)+b2*x(i)^2)x(i) }<E
and minimise
sum[i=1 to n] [(exp(b0+b1x(i)+b2x(i)^2))^2]
with the constraint that the sum of the exp(b0+b1x(i)+b2x(i)^2) terms equals n,
i.e. the mean of the exp(b0+b1x(i)+b2x(i)^2) terms equals 1.
I am trying to solve the following problem in R using Nloptr:
Objective is to maximise effective sample size (ESS), so I have been attempting to minimise the
inverse of ESS:
i.e: obj.func <- function(n, wi) {
ESS<- sum(wi^2)
return(ESS)}
Using simulated data as follows:
x1 <- runif(5)
n <- 5
y <- function(x1, b0, b1, b2) {
Y <- b0 + b1*x1 + b2*(x1^2)
return(Y)}
ym <- y(x1, b0=1.3,b1=-0.5,b2=0.2)
w <- function(ym, n){n * (exp((ym)) / sum(exp(ym))) } *#Function for weight*
wi <- w(ym, n)
We need to do this under the following constraint:
con <- function(x1, wi, n){
abs((weighted.mean(x1, wi))-(mean(x1))) <= 0.01 *#where E <- 0.01*}
I think that I am unable to use nloptr to complete this minimisation to get the optimum values of the b variables as the objective function and constraint function as the functions are not in the same terms. (constraint relies on x1 as well as n and wi)
Does anyone have any suggestions on how to solve this optimization problem? Or how I can get around my issues with nloptr? I have looked at the 'bb' package but this does not seem suitable.
Related
My goal is to basically migrate this code to R.
All the preprocessing wrt datasets has been already done, now however I am stuck in writing the "model" file. As a first attempt, and for the sake of clarity, I wrote the code which is shown below in R language.
What I want to do is to run an MCMC to have an estimate of the parameter R_t, given the daily reported data for Italian Country.
The main steps that have been pursued are:
Sample an array parameter, namely the log(R_t), from a Gaussian RW distribution
Gauss_RandomWalk <- function(N, x0, mu, variance) {
z <- cumsum(rnorm(n=N, mean=mu, sd=sqrt(variance)))
t <- 1:N
x <- (x0 + t*mu + z)
return(x)
}
log_R_t <- Gauss_RandomWalk(tot_dates, 0., 0., 0.035**2)
R_t_candidate <- exp(log_R_t)
Compute some quantities, that are function of this sampled parameters, namely the number of infections. This dependence is quite simple, since it is linear algebra:
infections <- rep(0. , tot_dates)
infections[1] <- exp(seed)
for (t in 2:tot_dates){
infections[t] <- sum(R_t_candidate * infections * gt_to_convolution[t-1,])
}
Convolve the array I have just computed with a delay distribution (onset+reporting delay), finally rescaling it by the exposure variable:
test_adjusted_positive <- convolve(infections, delay_distribution_df$density, type = "open")
test_adjusted_positive <- test_adjusted_positive[1:tot_dates]
positive <- round(test_adjusted_positive*exposure)
Compute the Likelihood, which is proportional to the probability that a certain set of data was observed (i.e. daily confirmed cases), by sampling the aforementioned log(R_t) parameter from which the variable positive is computed.
likelihood <- dnbinom(round(Italian_data$daily_confirmed), mu = positive, size = 1/6)
Finally, here we come to my BUGS model file:
model {
#priors as a Gaussian RW
log_rt[1] ~ dnorm(0, 0.035)
log_rt[2] ~ dnorm(0, 0.035)
for (t in 3:tot_dates) {
log_rt[t] ~ dnorm(log_rt[t-1] + log_rt[t-2], 0.035)
R_t_candidate[t] <- exp(log_rt[t])
}
# data likelihood
for (t in 2:tot_dates) {
infections[t] <- sum(R_t_candidate * infections * gt_to_convolution[t-1,])
}
test_adjusted_positive <- convolve(infections, delay_distribution)
test_adjusted_positive <- test_adjusted_positive[1:tot_dates]
positive <- test_adjusted_positive*exposure
for (t in 2:tot_dates) {
confirmed[t] ~ dnbinom( obs[t], positive[t], 1/6)
}
}
where gt_to_convolution is a constant matrix, tot_dates is a constant value and exposure is a constant array.
When trying to compile it through:
data <- NULL
data$obs <- round(Italian_data$daily_confirmed)
data$tot_dates <- n_days
data$delay_distribution <- delay_distribution_df$density
data$exposure <- exposure
data$gt_to_convolution <- gt_to_convolution
inits <- NULL
inits$log_rt <- rep(0, tot_dates)
library (rjags)
library (coda)
set.seed(1995)
model <- "MyModel.bug"
jm <- jags.model(model , data, inits)
It raises the following raising error:
Compiling model graph
Resolving undeclared variables
Allocating nodes
Deleting model
Error in jags.model(model, data, inits) : RUNTIME ERROR:
Compilation error on line 19.
Possible directed cycle involving test_adjusted_positive
Hence I am not even able to debug it a little, even though I'm pretty sure there is something wrong more in general but I cannot figure out what and why.
At this point, I think the best choice would be to implement a Metropolis Algorithm myself according to the likelihood above, but obviously, I would way much more prefer to use an already tested framework that is BUGS/JAGS, this is the reason why I am asking for help.
I am trying to convert an Excel spreadsheet that involves the solver function, using GRG Non-Linear to optimize 2 variables that return the lowest sum of squared errors. I have 4 known times (B) at 4 known distances(A). I need to create an optimization function to find what interaction of values for Vmax and Tau produce the lowest sum of squared errors. I have looked at the nls function and nloptr package but can't quite seem to piece them together. Current values for Vmax and Tau are what was determined via the excel solver function, just need to replicate in R. Any and all help would be greatly appreciated. Thank you.
A <- c(0,10, 20, 40)
B <- c(0,1.51, 2.51, 4.32)
Measured <- as.data.frame(cbind(A, B))
Corrected <- Measured
Corrected$B <- Corrected$B + .2
colnames(Corrected) <- c("Distance (yds)", "Time (s)")
Corrected$`X (m)` <- Corrected$`Distance (yds)`*.9144
Vmax = 10.460615006988
Tau = 1.03682513806393
Predicted_X <- c(Vmax * (Corrected$`Time (s)`[1] - Tau + Tau*exp(-Corrected$`Time (s)`[1]/Tau)),
Vmax * (Corrected$`Time (s)`[2] - Tau + Tau*exp(-Corrected$`Time (s)`[2]/Tau)),
Vmax * (Corrected$`Time (s)`[3] - Tau + Tau*exp(-Corrected$`Time (s)`[3]/Tau)),
Vmax * (Corrected$`Time (s)`[4] - Tau + Tau*exp(-Corrected$`Time (s)`[4]/Tau)))
Corrected$`Predicted X (m)` <- Predicted_X
Corrected$`Squared Error` <- (Corrected$`X (m)`-Corrected$`Predicted X (m)`)^2
#Sum_Squared_Error <- sum(Corrected$`Squared Error`)
is your issue still unsolved?
I'm working on a similar problem and I think I could help.
First you have to define a function that will be the sum of the errors, which has for variables Vmax and Tau.
Then you can call an optimisation algorithm that will change these variables and look for a minimum of your function. optim() might be sufficient for your application, but here is the documentation for nloptr:
https://www.rdocumentation.org/packages/nloptr/versions/1.0.4/topics/nloptr
and here is a list of optimisation packages in R:
https://cran.r-project.org/web/views/Optimization.html
Edit:
I quickly recoded the way I would do it. I'm a beginner, so it's probably not the best way but it still works.
A <- c(0,10, 20, 40)
B <- c(0,1.51, 2.51, 4.32)
Measured <- as.data.frame(cbind(A, B))
Corrected <- Measured
Corrected$B <- Corrected$B + .2
colnames(Corrected) <- c("Distance (yds)", "Time (s)")
Corrected$`X (m)` <- Corrected$`Distance (yds)`*.9144
#initialize values
Vmax0 = 15
Tau0 = 5
x0 = c(Vmax0,Tau0)
#define function to optimise: optim will minimize the output
f <- function(x) {
y=0
#variables will be optimise to find the minimum value of f
Vmax = x[1]
Tau = x[2]
Predicted_X <- Vmax * (Corrected$`Time (s)` - Tau + Tau*exp(-Corrected$`Time (s)`/Tau))
y = sum((Predicted_X - Corrected$`X (m)`)^2)
return(y)
}
#call optim: results will be available in variable Y
Y<-optim(x0,f)
If you type Y into the console, you will find that the solver finds the same values as Excel, and convergence is achieved.
In R, there is no need to define columns in data frames with brackets as you did, instead use vectors. You should probably follow a tutorial about this first.
Also it is misleading that you set inital values as values that were already the optimal ones. If you do this then optim() will not optimise further.
Here is the documentation for optim:
https://stat.ethz.ch/R-manual/R-devel/library/stats/html/optim.html
and a tutorial on how to use functions:
https://www.datacamp.com/community/tutorials/functions-in-r-a-tutorial
Cheers
I am looking for a fast way to do nonnegative quantile and Huber regression in R (i.e. with the constraint that all coefficients are >0). I tried using the CVXR package for quantile & Huber regression and the quantreg package for quantile regression, but CVXR is very slow and quantreg seems buggy when I use nonnegativity constraints. Does anybody know of a good and fast solution in R, e.g. using the Rcplex package or R gurobi API, thereby using the faster CPLEX or gurobi optimizers?
Note that I need to run a problem size like below 80 000 times, whereby I only need to update the y vector in each iteration, but still use the same predictor matrix X. In that sense, I feel it's inefficient that in CVXR I now have to do obj <- sum(quant_loss(y - X %*% beta, tau=0.01)); prob <- Problem(Minimize(obj), constraints = list(beta >= 0)) within each iteration, when the problem is in fact staying the same and all I want to update is y. Any thoughts to do all this better/faster?
Minimal example:
## Generate problem data
n <- 7 # n predictor vars
m <- 518 # n cases
set.seed(1289)
beta_true <- 5 * matrix(stats::rnorm(n), nrow = n)+20
X <- matrix(stats::rnorm(m * n), nrow = m, ncol = n)
y_true <- X %*% beta_true
eps <- matrix(stats::rnorm(m), nrow = m)
y <- y_true + eps
Nonnegative quantile regression using CVXR :
## Solve nonnegative quantile regression problem using CVX
require(CVXR)
beta <- Variable(n)
quant_loss <- function(u, tau) { 0.5*abs(u) + (tau - 0.5)*u }
obj <- sum(quant_loss(y - X %*% beta, tau=0.01))
prob <- Problem(Minimize(obj), constraints = list(beta >= 0))
system.time(beta_cvx <- pmax(solve(prob, solver="SCS")$getValue(beta), 0)) # estimated coefficients, note that they ocasionally can go - though and I had to clip at 0
# 0.47s
cor(beta_true,beta_cvx) # correlation=0.99985, OK but very slow
Syntax for nonnegative Huber regression is the same but would use
M <- 1 ## Huber threshold
obj <- sum(CVXR::huber(y - X %*% beta, M))
Nonnegative quantile regression using quantreg package :
### Solve nonnegative quantile regression problem using quantreg package with method="fnc"
require(quantreg)
R <- rbind(diag(n),-diag(n))
r <- c(rep(0,n),-rep(1E10,n)) # specify bounds of coefficients, I want them to be nonnegative, and 1E10 should ideally be Inf
system.time(beta_rq <- coef(rq(y~0+X, R=R, r=r, tau=0.5, method="fnc"))) # estimated coefficients
# 0.12s
cor(beta_true,beta_rq) # correlation=-0.477, no good, and even worse with tau=0.01...
To speed up CVXR, you can get the problem data once in the beginning, then modify it within a loop and pass it directly to the solver's R interface. The code for this is
prob_data <- get_problem_data(prob, solver = "SCS")
Then, parse out the arguments and pass them to scs from the scs library. (See Solver.solve in solver.R). You'll have to dig into the details of the canonicalization, but I expect if you're just changing y at each iteration, it should be a straightforward modification.
Is there a way to specify minimum or maximum possible values in a forecast done with ETS/ARIMA models?
Such as when forecasting a trend in % that can only go between 0% and 100%.
I am using R package forecast (and function forecast).
If your time series y has a natural bound [a, b], you should take a "logit-alike" transform first:
f <- function (x, a, b) log((x - a) / (b - x))
yy <- f(y, a, b)
Then the resulting yy is unbounded on (-Inf, Inf), suitable for Gaussian error assumption. Use yy for time series modelling, and take back-transform later on the prediction / forecast:
finv <- function (x, a, b) (b * exp(x) + a) / (exp(x) + 1)
y <- finv(yy, a, b)
Note, the above transform f (hence finv) is monotone, so if the 95%-confidence interval for yy is [l, u], the corresponding confidence interval for y is [finv(l), finv(u)].
If your y is only bounded on one side, consider "log-alike" transform.
bounded on [a, Inf), consider yy <- log(y - a);
bounded on (-Inf, a], consider yy <- log(a - y).
Wow, I didn't know Rob Hyndman has a blog. Thanks to #ulfelder for providing it. I added it here to make my answer more solid: Forecasting within limits.
This one is more specific, which I have not covered. What to do when data need a log transform but it can take 0 somewhere. I would just add a small tolerance, say yy <- log(y + 1e-7) to proceed.
I am writing my masters thesis and I got stuck with this problem in my R code. Mathematically, I want to solve this system of non-linear equations with the R-package “nleqslv”:
fnewton <- function(x){
y <- numeric(2)
d1 = (log(x[1]/D1)+(R+x[2]^2/2)*T)/x[2]*sqrt(T)
d2 = d1-x[2]*sqrt(T)
y1 <- SO1 - (x[1]*pnorm(d1) - exp(-R*T)*D1*pnorm(d2))
y2 <- sigmaS*SO1 - pnorm(d1)*x[2]*x[1]
y}
xstart <- c(21623379, 0.526177094846878)
nleqslv(xstart, fnewton, control=list(btol=.01), method="Newton")
I have tried several versions of this code and right now I get the error:
error: error in pnorm(q, mean, sd, lower.tail, log.p): not numerical.
Pnorm is meant to be the cumulative standard Normal distribution of d1and d2 respectively. I really don’t know, what I am doing wrong as I oriented my model on Teterevas slides ( on slide no.5 is her model code), who’s presentation is the first result by googeling
https://www.google.de/search?q=moodys+KMV+in+R&rlz=1C1SVED_enDE401DE401&aq=f&oq=moodys+KMV+in+R&aqs=chrome.0.57.13309j0&sourceid=chrome&ie=UTF-8#q=distance+to+default+in+R
Like me, however more successfull, she calculates the Distance to Default risk measure via the Black-Scholes-Merton approach. In this model, the value of equity (usually represented by the market capitalization, ->SO1) can be written as a European call option – what I labeled y2 in the above code, however, the equation before is set to 0!
The other variables are:
x[1] -> the variable I want to derive, value of total assets
x[2] -> the variable I want to derive, volatility of total assets
D1 -> the book value of debt (1998-2009)
R -> a risk-free interest rate
T -> is set to 1 (time)
sigmaS -> estimated (historical) equity volatility
Thanks already!!! I would be glad, anyone could help me.
Caro
I am the author of nleqslv and I'm quite suprised at how you are using it.
As mentioned by others you are not returning anything sensible.
y1 should be y[1] and y2 should be y[2]. If you want us to say sensible things you will have to provide numerical values for D1, R, T, sigmaS and SO1. I have tried this:
T <- 1; D1 <- 1000; R <- 0.01; sigmaS <- .1; SO1 <- 1000
These have been entered before the function definition. See this
library(nleqslv)
T <- 1
D1 <- 1000
R <- 0.01
sigmaS <- .1
SO1 <- 1000
fnewton <- function(x){
y <- numeric(2)
d1 <- (log(x[1]/D1)+(R+x[2]^2/2)*T)/x[2]*sqrt(T)
d2 <- d1-x[2]*sqrt(T)
y[1] <- SO1 - (x[1]*pnorm(d1) - exp(-R*T)*D1*pnorm(d2))
y[2] <- sigmaS*SO1 - pnorm(d1)*x[2]*x[1]
y
}
xstart <- c(21623379, 0.526177094846878)
nleqslv has no problem in finding a solution in this case. Solution found is : c(1990.04983,0.05025). There appears to be no need to set the btol parameter and you can use method Broyden.