I would like to maximize a function of x1, x2, and x3 as follows
f <- function(x) x[1]*14.1638 + x[2]*4.2062 +
x[3]*0.6700 - x[1]*x[2]*2.2175 + x[1]*x[3]*2.8800 +
x[2]*x[3]*2.0450 + x[1]*x[1]*9.9863 -
x[2]*x[2]*12.6738 - x[3]*x[3]*10.9062 + 36.4100
params <- c(1,1,1)
r <- optimx(params, f,gr=NULL, hess=NULL, lower=-1, upper=1,
method=c("Nelder-Mead", "L-BFGS-B"), itnmax=c(50),
maximize=TRUE )
r$convergence == 0
r$par
But I am getting the warning message
Error in optimx.check(par, optcfg$ufn, optcfg$ugr, optcfg$uhess, lower, :
Cannot evaluate function at initial parameters
I am pretty sure I am missing something basic in function parameters but I am not able to figure out what.
It took some digging to figure it out (debug(optimx:::optim.check))), but it looks like this is a confusing error message that occurs because you specified maximize=TRUE rather than control=list(maximize=TRUE) (optimx tried to pass maximize=TRUE through to your function as an additional argument, which failed).
Try:
r <- optimx(params, f,gr=NULL, hess=NULL, lower=-1, upper=1,
method=c("Nelder-Mead", "L-BFGS-B"), itnmax=c(50),
control=list(maximize=TRUE ))
Related
I am trying to implement a new nonlinear function to use in nlmer function in lme4 package. But I'm not sure what the problem is. This is the first time I'm trying to use nlmer but I'm following all the instructions I've found on the internet. The first error is about my dataframe.
data <- read.csv(paste("C:/Users/oguz/Desktop/Runs4SiteModels/db/", "DB4NLSiteModel", Periods[i],".txt", sep=""), sep = "", header = TRUE)
psa_rock <- data$PSAr
nparams <- c("c")
nonl_fn <- deriv(~ log(( psa_rock + c)/c),
namevec = c("c"),
function.arg=c("c", psa_rock))
fm <- nlmer(log(data$PSAm) ~ nonl_fn(c, psa_rock) ~ 1 + data$M1 + data$M3 + data$M85 + data$Nflag + data$Rflag + data$FDepth +
data$Dist1 + data$Dist3 + data$VN + (exp(-1*exp(2*log(data$Vs)- 11)) * log((data$PSAr + c) / c) ) +
(1|data$EQID) + (1|data$STID), data=data, start=c(c=0.1))
When I run this code, I'm getting the following error:
Error in model.frame.default(data = data, drop.unused.levels = TRUE, formula = log(data$PSAm) ~ :
invalid type (list) for variable 'data'
which I wasn't getting it while using lmer function (of course without the nonlinear function). That's why I'm thinking my problem is not about my dataframe.
Other issue that I couldn't stop thinking about, the part in the fixed-effects:
(exp(-1*exp(2*log(data$Vs)- 11)) * log((data$PSAr + c) / c) )
as you can see my nonlinear function also takes a part in my fixed-effects formula and I'm not quite sure how to implement that. I hope my way is correct but because of my first problem, I couldn't find an opportunity to test that.
I don't know why I get an error message when I'm trying to use optim in R.
I have following data:
x <- c(6.0401209, 7.2888217, 0.4868070,
1.1699703, 51.5998419, 11.8766734,
2.3873264, 16.9583702, 21.6142835,
0.3133089, 3.4178360, 4.4367427,
2.0205100, 10.5798884, 0.4890031,
1.6734176, 10.2809820, 6.4705424,
5.6801965, 0.9438700)
And following log-likelihood function:
log.lik.bs <- function(gamma, betha, z){
n <- length(z)
- n * log(gamma) - n * log(2*sqrt(2*2*pi)) - sum(log(z)) + sum(log(sqrt(z/betha)) + sqrt(betha/z)) - (1/2*gamma^2) * sum((sqrt(z/betha) - sqrt(betha/z))^2)
}
What I'm trying to do is following:
optim(c(2, 6), log.lik.bs, control=list(fnscale=-1), x=x, method="BFGS")$par
But I get an error message:
Error in fn(par, ...) :
unused argument (x = c(6.04012089885228, 7.28882174812723, 0.486806990614708, 1.1699703323488, 51.5998418613029, 11.8766733963947, 2.38732637900487, 16.9583701851951, 21.6142834611592, 0.313308870127425, 3.41783600439905, 4.43674270859797, 2.02051001746263, 10.5798883747597, 0.489003100259996, 1.67341757119939, 10.2809820486722, 6.4705423816332, 5.68019649178721, 0.943869996033357))
It is not quite clear which parameters you are trying to optimize. I assume you want to optimize log.lik.bs with respect to gamma and betha for given z with initial values 2 and 6. In that case you have two errors in your code:
log.lik.bs is expecting an argument named z but you are providing an argument x. That is the error you are getting. Fix: z = x
When using optim your target function must take a single argument for the parameters. From ?optim:
A function to be minimized (or maximized), with first argument the vector of parameters over which minimization is to take place. It should return a scalar result.
Combining this I get:
x <- c(6.0401209, 7.2888217, 0.4868070,
1.1699703, 51.5998419, 11.8766734,
2.3873264, 16.9583702, 21.6142835,
0.3133089, 3.4178360, 4.4367427,
2.0205100, 10.5798884, 0.4890031,
1.6734176, 10.2809820, 6.4705424,
5.6801965, 0.9438700)
log.lik.bs <- function(x, z){
gamma <- x[1]
betha <- x[2]
n <- length(z)
- n * log(gamma) - n * log(2*sqrt(2*2*pi)) - sum(log(z))
+ sum(log(sqrt(z/betha)) + sqrt(betha/z))
- (1/2*gamma^2) * sum((sqrt(z/betha) - sqrt(betha/z))^2)
}
optim(c(2, 6), log.lik.bs, control=list(fnscale=-1), z=x, method="BFGS")$par
Unfortunately this still throws an error:
Error in optim(c(2, 6), log.lik.bs, control = list(fnscale = -1), z = x, :
non-finite finite-difference value [1]
In addition there are several warnings that NaNs where introduced by sqrt and log. So my interpretation of your question might be wrong. After all, the function goes to infinity as gamma goes to zero.
I've got the following code:
theta=0.05
n=1000
m=200
r=rnorm(2000)
#ER check function
nu=Vectorize(function(a,tau){return(abs(tau-(a<0))*a^2)})
#Selecting 10 lowest sum values (lowest10 function returns indices)
lowest10=function(x){
values=sort(x)[1:min(10,length(x))]
indices=match(values,x)
return(indices)
}
sym.expectile=function(beta,e,abs.r){return(beta[1]+beta[2]*e+beta[3]*abs.r)}
ERsum=function(beta,tau,start,end){
y=r[(start+1):end]
X1=rep(1,n-1)
X3=abs(r[start:(end-1)])
X2=c()
X2[1]=e.sym.optimal[start-m]
for (i in 2:(n-1)){
X2[i]=sym.expectile(beta,X2[i-1],X3[i-1])
}
X=matrix(c(X1,X2,X3),ncol=3)
res=y-X%*%beta
sum.nu=mean(nu(res,tau))
return(sum.nu)
}
ERsum.gr=function(beta,tau,start,end){
y=r[(start+1):end]
X1=rep(1,n-1)
X3=abs(r[start:(end-1)])
X2=c()
X2[1]=e.sym.optimal[start-m]
for (i in 2:(n-1)){
X2[i]=sym.expectile(beta,X2[i-1],X3[i-1])
}
X=matrix(c(X1,X2,X3),ncol=3)
partial.beta0=c()
for (i in 1:(n-1)){partial.beta0[i]=-(1-beta[2]^(i))/(1-beta[2])}
gr.beta0=2/T*sum(abs(tau-(y<X%*%beta))*(y-X%*%beta)*partial.beta0)/1000
partial.beta1=c()
partial.beta1[1]=-X2[1]
for (i in 2:(n-1)){partial.beta1[i]=partial.beta1[i-1]*beta[2]-X2[i]}
gr.beta1=2/T*sum(abs(tau-(y<X%*%beta))*(y-X%*%beta)*partial.beta1)/1000
partial.beta2=c()
partial.beta2[1]=-X3[1]
for (i in 2:(n-1)){partial.beta2[i]=partial.beta2[i-1]*beta[2]-X3[i]}
gr.beta2=2/T*sum(abs(tau-(y<X%*%beta))*(y-X%*%beta)*partial.beta2)/1000
c(gr.beta0,gr.beta1,gr.beta2)
}
beta=matrix(nrow=1e4,ncol=3)
beta[,1]=runif(1e4,-1,0)#beta0
beta[,2]=runif(1e4,0,1)#beta1
beta[,3]=runif(1e4,-1,0)#beta2
e.sym.optimal=c()
tau.found.sym.optim=0.02234724
library('expectreg')
e.sym.optimal[1]=expectile(r[1:m],tau.found.sym.optim)
ERsums.sym=c()
for (i in 1:nrow(beta)){
ERsums.sym[i]=ERsum(beta[i,],tau.found.sym.optim,m+1,m+n)
}
initialbeta.esym=beta[lowest10(ERsums.sym),]
intermedietebeta.esym=matrix(ncol=3,nrow=10)
for (i in 1:10){
intermedietebeta.esym[i,]=optim(initialbeta.esym[i,],ERsum,
gr=ERsum.gr,tau=tau.found.sym.optim,
start=m+1,end=m+n,
method="BFGS")$par
}
I tried to replace the optim function with optimx, but got the following error:
Error: Gradient function might be wrong - check it!
To check if my gradient is ok I tried to evaluate values of gradient function using function grad from numDeriv and directly calling my ERsum.gr function. For the sample vector
beta
[1] -0.8256490 0.7146256 -0.4945032
I obtained following results:
>grad(function(beta) ERsum(c(beta[1],beta[2],beta[3]),tau.found.sym.optim,m+1,m+n),beta)
[1] -0.6703170 2.8812666 -0.5573101
> ERsum.gr2(beta,tau.found.sym.optim,m+1,m+n)
[1] -0.6696467 2.8783853 -0.5567527
So here is my question: is it possible that these differences are just some numerical errors caused by rounding down the partial.beta0, partial.beta1, partial.beta2 which are just the components of the sum representing gradient? I think so, because if my analytical formula for gradient misses something, the discrepancies would be probably much larger, but how can I be sure? If this is a case is there any other way to obtain more accurate values of gradient?
You've got further problems down the line even if you solve the question of whether that is really a proper gradient, which I see as too complex to tackle. If you take out the gr argument and try to run with only optimx instead of optim, you get:
Error in intermedietebeta.esym[i, ] <- optimx(initialbeta.esym[i, ], ERsum, :
number of items to replace is not a multiple of replacement length
This probably relates to the fact that optimx does not return the same structure as is returned by optim:
> optimx(initialbeta.esym[i,],ERsum,
+ tau=tau.found.sym.optim,
+ start=m+1,end=m+n,
+ method="BFGS")$par
NULL
> optimx(initialbeta.esym[i,],ERsum,
+ tau=tau.found.sym.optim,
+ start=m+1,end=m+n,
+ method="BFGS") # leave out `$par`
p1 p2 p3 value fevals gevals niter convcode kkt1 kkt2 xtimes
BFGS -1.0325 0.2978319 0.04921863 0.09326904 102 100 NA 1 TRUE FALSE 3.366
If you disagree with the decision to allow a default gradient estimate, hten you need to narrow down your debugging to the function that throws the error:
Error: Gradient function might be wrong - check it!
> traceback()
3: stop("Gradient function might be wrong - check it! \n", call. = FALSE)
2: optimx.check(par, optcfg$ufn, optcfg$ugr, optcfg$uhess, lower,
upper, hessian, optcfg$ctrl, have.bounds = optcfg$have.bounds,
usenumDeriv = optcfg$usenumDeriv, ...)
1: optimx(initialbeta.esym[i, ], ERsum, gr = ERsum.gr, tau = tau.found.sym.optim,
start = m + 1, end = m + n, method = "BFGS")
And look at the documentation (there was no help page) and code for optimx:::optimx.check. This is the section of code that does the checking:
if (!is.null(ugr) && !usenumDeriv) {
gname <- deparse(substitute(ugr))
if (ctrl$trace > 0)
cat("Analytic gradient from function ", gname,
"\n\n")
fval <- ufn(par, ...)
gn <- grad(func = ufn, x = par, ...)
ga <- ugr(par, ...)
teps <- (.Machine$double.eps)^(1/3)
if (max(abs(gn - ga))/(1 + abs(fval)) >= teps) {
stop("Gradient function might be wrong - check it! \n",
call. = FALSE)
optchk$grbad <- TRUE
}
I have a data.frame with many columns of the form containing the aggregated values for each time point of variables x,y,z,w ...an:
Time x_mean x_sd y_mean y_sd z_mean y_sd w_mean w_sd ...
Now I want to write a function that plots the mean and a confidence band of +/-1SD around it, with ggplot2. Currently my code looks like:
plotfunc <- function(ds1,val) {
val_mean <- paste(val,"_mean",sep="")
val_p_sd <- paste(val,"_mean + ",val,"_sd",sep="")
val_m_sd <- paste(val,"_mean - ",val,"_sd",sep="")
ggplot() + geom_line(data=ds1,aes_q(x=as.name("TIME"),y=as.name(val_mean),color="good")) +
geom_ribbon(data=ds1,aes_q(x=as.name("TIME"),ymin=as.name(val_m_sd),ymax=as.name(val_p_sd),alpha=0.3,fill="good"))
}
And I call it with:
plotfunc(df,"x")
It complains:
Error in eval(expr, envir, enclos) : object 'x_mean - x_sd' not found
How do I get the upper and lower bounds? Do I need to use substitute or quote ?
I used aes_string and corrected some syntax errors in your function code:
- color "good" unkown
- the color argument, which is specified to a fixed value, has hence to be outside the aes function
df = data.frame("TIME"=11:20, "x_mean"=rnorm(10, mean=10), "x_sd"=rnorm(10, mean=1, sd=0.1),
"y_mean"=rnorm(10, mean=12), "y_sd"=rnorm(10, mean=2, sd=0.2))
plotfunc <- function(ds1,val) {
val_mean <- paste(val,"_mean",sep="")
val_p_sd <- paste(val,"_mean + ",val,"_sd",sep="")
val_m_sd <- paste(val,"_mean - ",val,"_sd",sep="")
ggplot() + geom_line(data=ds1,aes_string(x=as.name("TIME"),y=as.name(val_mean)),color="red") +
geom_ribbon(data=ds1,aes_string(x=as.name("TIME"),ymin=as.name(val_m_sd),ymax=as.name(val_p_sd)),alpha=0.3,fill="blue")
}
plotfunc(df,"x")
Is that OK for you?
I am trying to formulate the priors by using total counts and beta distribution.
I have following written:
quantile(df$row, probs=c(0.00001, 0.5, 0.99999))
quantile1 <- list(p=0.5, x=8)
quantile2 <- list(p=0.99999, x=10)
quantile3 <- list(p=0.00001, x=1)
library("LearnBayes")
findBeta <- function(quantile1,quantile2,quantile3)
quantile1_p <- quantile1[[1]]; quantile1_q <- quantile1[[2]]
quantile2_p <- quantile2[[1]]; quantile2_q <- quantile2[[2]]
quantile3_p <- quantile3[[1]]; quantile3_q <- quantile3[[2]]
priorA <- beta.select(list(p=0.5, x=8), list(p=0.99999, x=10))
and once I am trying to calculate priorA using beta.select function I get following error:
Error in if (p0 < p) m.hi = m0 else m.lo = m0 :
missing value where TRUE/FALSE needed
In addition: Warning message:
In pbeta(x, K * m0, K * (1 - m0)) : NaNs produced
I just can't get rid of the error and do not know how to approach it any more. Urgently need help.
I am guessing (completely out of thin air) that you are dealing with percentages. In which case you want to use x/100
beta.select(list(p=0.5, x=.08), list(p=0.9, x=.10))
# [1] 28.02 318.74
Either way, while it would be nice of beta.select to throw a more appropriate error message (or rather, to have an error check in there), the root of the issue is that your x's are out of bounds. (As #Didzis noted, the interval for a beta dist is [0, 1])