I am trying to find global minimum (-5 <= (x,y) <= 5) using the function below. When I use optimize, getting "Error in T %*% x : non-conformable arguments". Am I doing to something wrong?
T = qr.Q(qr(matrix(c(1,2,3,4),nrow=2,ncol=2,byrow=T)))
fitness = function(x){
z = T%*%x+c(.5,.5);
s = 100*(z[1]^2-z[2])^2 + (z[1]-1)^2;
return(10*(s/4000-cos(s))+10)
}
optimize(fitness, c(-0.5, 0.5), upper = c(5,5), lower = c(-5,-5))
Error in T %*% x : non-conformable arguments
You are getting that error because you are using optimize() (good for 1D optimization problems) on a 2D optimization problem.
As indicated by Rui Barradas you should use optim() (which is used for multi-dimensional optimization problems).
The following works:
T = qr.Q(qr(matrix(c(1,2,3,4),nrow=2,ncol=2,byrow=TRUE)))
fitness = function(x){
z = T%*%x+c(.5,.5);
s = 100*(z[1]^2-z[2])^2 + (z[1]-1)^2;
return(10*(s/4000-cos(s))+10)
}
fitness.optim = optim(c(-0.5, 0.5), fitness)
where fitness.optim results in:
> fitness.optim
$par
[1] -0.4550863 0.5470252
$value
[1] 0.298451
$counts
function gradient
59 NA
$convergence
[1] 0
$message
NULL
So, the optimum (minimum) fitness value is found at x_opt = fitness.optim$par i.e. x_opt = c(-0.4550863, 0.5470252) achieving the value fitness.optim$value = 0.298451.
Related
Im trying to use DEoptim to find the global minimum of z in in -1 < x < 1 , -1 < y < 1, but im getting Error in FUN(newX[, i], ...) : argument "y" is missing, with no default and I dont know what im supposed to do for the mission "y"
install.packages("Rmpfr")
install.packages("DEoptim")
library(gmp)
library(Rmpfr)
library(parallel) # https://cran.r-project.org/web/packages/DEoptim/vignettes/DEoptim.pdf
library(DEoptim)
z = function(x,y) {
(exp(sin(60.0*x)) + sin(50.0*exp(y)) + sin(80.0*sin(x)) + sin(sin(70.0*y)) - sin(10.0*(x+y)) + (x*x+y*y)/4.0)
}
optimized_Minimum <- DEoptim(z, lower = c(-1,-1), upper = c(1,1),
control=list(storepopfrom=1, trace=FALSE))
# optimized_Minimum <- optim(z, lower = c(-1,-1), upper = c(1,1), method = "Brent")
DEoptim is not expecting you to pass it 2 separate arguments to your function (x and y), but you can still solve for multiple variables.
You need to pass in a vector rather than 2 separate variables with the DEoptim package, as with the optim function.
I tested this with the functions from the linked solution and it worked:
fxcalc <- function(s,t){(1-(1-(parametros$ap/xm)^(s))^t)*100}
suma <- function(s,t){(parametros$fx-fxcalc(s,t))^2}
func <- function(st){
s <- st[1]
t <- st[2]
sum(suma(s,t))
}
optimized_Minimum <- DEoptim(func, lower = c(-1,-1), upper = c(1,1),
control=list(storepopfrom=1, trace=FALSE))
summary(optimized_Minimum)
***** summary of DEoptim object *****
best member : 1 1
best value : 0
after : 200 generations
fn evaluated : 402 times
*************************************
How would you find local maxima for the function below, with the two inputs having different intervals?
f <- function(x, y) {
y/50*(100*x)^0.9 + (50-y)/y*(80*(10-x))^0.8
}
# interval for y = (0, 50)
# interval for x = (0, 10)
I looked into using the optim function, but I couldn't figure out how to set "par," intervals, and other arguments for the two input variables.
optim expects a function with a vector argument (+ optional parameters), i.e. to make the function given in the question work with optim one has to slightly alter the function or use some kind of wrapper function, like so:
# Function of two scalar inputs
f_xy <- function(x, y) {
y / 50 * (100 * x)^0.9 + (50 - y) / y * (80 * (10 - x))^0.8
}
# Wrapper or helper function with vector argument
f <- function(x) {
y <- x[2]
x <- x[1]
f_xy(x, y)
}
# Default optim with starting value c(x = 5, y = 20)
optim(c(5, 20), fn = f)
Note: By default optim performs minimization.
To maximise: Set control = list(fnscale = -1) (Thanks to #alistaire for pointing that out in the comments.)
optim(c(5, 20), fn = f, control = list(fnscale = -1))
However, for the function given in the question the optim output shows that the algorithm has not converged ($convergence != 0) (Thanks to #alistaire for pointing that out in the comments.):
optim(c(5, 20), fn = f, control = list(fnscale = -1))
#> $par
#> [1] 1.591824e+00 3.861200e-34
#>
#> $value
#> [1] 2.368542e+37
#>
#> $counts
#> function gradient
#> 501 NA
#>
#> $convergence
#> [1] 1
#>
#> $message
#> NULL
In the case given $convergence of 1 means that the maximum number of iterations was reached. One may tackle this problem by increasing the maximum number of iteration by e.g. setting control = list(..., maxit = 500)). However, this will not solve the problem as optim still fails to converge.
I have the following function.
Let F(.) is the cumulative distribution function of the gamma distribution with shape = 1 and rate =1. The denominator is the survival function S(X) = 1 - F(X). The g(x) is the mean residual life function.
I wrote the following function in r.
x = 5
denominator = 1 -pgamma(x, 1, 1)
numerator = function(t) (1 - pgamma(t, 1, 1))
intnum = integrate(numerator , x, Inf)
frac = intnum$value/denominator
frac
How can I find the maximum of the function g(x) for all possible values of X >= 0? Am I able to do this in r? Thank you very much for your help.
Before start, I defined the function you made
surviveFunction<-function(x){
denominator = 1 -pgamma(x, 1, 1)
numerator = function(t) (1 - pgamma(t, 1, 1))
# I used sapply to get even vector x
intnum = sapply(x,function(x){integrate(numerator , x, Inf)$value})
frac = intnum/denominator
return(frac)
}
Then let's fit our function to function called 'curve' it will draw the plot with continuous data.
The result is shown below:
df = curve(surviveFunction, from=0, to=45)
plot(df, type='l')
And adjust the xlim to find the maximum value
df = curve(surviveFunction, from=0, to=45,xlim = c(30,40))
plot(df, type='l')
And now we can guess the global maximum is located in near 35
I suggest two options to find the global maximum.
First using the df data to find maximum:
> max(df$y,na.rm = TRUE)
1.054248 #maximum value
> df$x[which(df$y==(max(df$y,na.rm = TRUE)))]
35.55 #maximum value of x
Second using the optimize:
> optimize(surviveFunction, interval=c(34, 36), maximum=TRUE)
$maximum
[1] 35.48536
$objective
[1] 1.085282
But the optimize function finds the not the global maximum value i think.
If you see below
optimize(surviveFunction, interval=c(0, 36), maximum=TRUE)
$maximum
[1] 11.11381
$objective
[1] 0.9999887
Above result is not the global maximum I guess it is local maximum.
So, I suggest you using first solution.
A related question is "using fitdist from fitdistplus with binomial distribution
". fitdistrplus::fitdist is a function that takes univariate data and starting guess for parameters. To fit binomial and betabinomial data, while univariate, the size is also needed. If the size is fixed for every datum, then the aforementioned link has the fix needed. However if the sizes vary and a vector needs to be passed, I'm unsure how to get a properly functioning call.
opt_one in the code below was the solution that was offered in the aforementioned linked post -- that is, the cluster size is known and fixed. For opt_one, I incorrectly specify fix.arg=list(size=125) (in essence making every element of N=125) and this is close enough and the code runs. However, the cluster sizes in N actually vary. I try to specify this in opt_two and get an error. Any thoughts would be appreciated.
library(fitdistrplus)
library(VGAM)
set.seed(123)
N <- 100 + rbinom(1000,25,0.9)
Y <- rbetabinom.ab(rep(1,length(N)), N, 1, 2)
head(cbind(Y,N))
opt_one <-
fitdist(data=Y,
distr=pbetabinom.ab,
fix.arg=list(size=125),
start=list(shape1=1,shape2=1)
)
opt_one
Which gives:
> head(cbind(Y,N))
Y N
[1,] 67 123
[2,] 14 121
[3,] 15 123
[4,] 42 121
[5,] 86 120
[6,] 28 125
> opt_one <-
+ fitdist(data=Y,
+ distr=pbetabinom.ab,
+ fix.arg=list(size=125),
+ start=list(shape1=1,shape2=1)
+ )
Warning messages:
1: In fitdist(data = Y, distr = pbetabinom.ab, fix.arg = list(size = 125), :
The dbetabinom.ab function should return a zero-length vector when input has length zero
2: In fitdist(data = Y, distr = pbetabinom.ab, fix.arg = list(size = 125), :
The pbetabinom.ab function should return a zero-length vector when input has length zero
> opt_one
Fitting of the distribution ' betabinom.ab ' by maximum likelihood
Parameters:
estimate Std. Error
shape1 0.9694054 0.04132912
shape2 2.1337839 0.10108720
Fixed parameters:
value
size 125
Not, bad, as the shape1 and shape2 parameters were 1 and 2, respectively, as specified when we created Y. Here's option 2:
opt_two <-
fitdist(data=Y,
distr=pbetabinom.ab,
fix.arg=list(size=N),
start=list(shape1=1,shape2=1)
)
Which gives an error:
> opt_two <-
+ fitdist(data=Y,
+ distr=pbetabinom.ab,
+ fix.arg=list(size=N),
+ start=list(shape1=1,shape2=1)
+ )
Error in checkparamlist(arg_startfix$start.arg, arg_startfix$fix.arg, :
'fix.arg' must specify names which are arguments to 'distr'.
An Attempt after initial posting (thanks to Dean Follmann)
I know I can code my own betabinomial likelihood (opt_three, presented below), but would really like to use the tools provided with having a fitdist object -- that is, to have opt_two working.
library(Rfast)
loglik <-function(parm){
A<-parm[1];B<-parm[2]
-sum( Lgamma(A+B) - Lgamma(A)- Lgamma(B) + Lgamma(Y+A) + Lgamma(N-Y+B) - Lgamma(N+A+B) )
}
opt_three <- optim(c(1,1),loglik, method = "L-BFGS-B", lower=c(0,0))
opt_three
Which gives:
> opt_three
$par
[1] 0.9525161 2.0262342
$value
[1] 61805.54
$counts
function gradient
7 7
$convergence
[1] 0
$message
[1] "CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH"
Also related is Ben Bolker's answer using mle2. The fitdist solution remains at large.
Look at example 4 of the ?fitdistrplus::fitdist() help page:
# (4) defining your own distribution functions, here for the Gumbel distribution
# for other distributions, see the CRAN task view
# dedicated to probability distributions
#
dgumbel <- function(x, a, b) 1/b*exp((a-x)/b)*exp(-exp((a-x)/b))
pgumbel <- function(q, a, b) exp(-exp((a-q)/b))
qgumbel <- function(p, a, b) a-b*log(-log(p))
fitgumbel <- fitdist(serving, "gumbel", start=list(a=10, b=10))
summary(fitgumbel)
plot(fitgumbel)
and then -- feeling inspired and informed because you actually RTM -- make your own [dpq] functions with N specified:
dbbspecifiedsize <- function(x, a, b) dbetabinom.ab(x, size=N, shape1=a, shape2=b)
pbbspecifiedsize <- function(q, a, b) pbetabinom.ab(q, size=N, shape1=a, shape2=b)
qbbspecifiedsize <- function(p, a, b) qbetabinom.ab(p, size=N, shape1=a, shape2=b)
opt_four <-
fitdist(data=Y,
distr="bbspecifiedsize",
start=list(a=1,b=1)
)
opt_four
which gives:
> opt_four
Fitting of the distribution ' bbspecifiedsize ' by maximum likelihood
Parameters:
estimate Std. Error
a 0.9526875 0.04058396
b 2.0261339 0.09576709
which is quite similar to the estimates of opt_three and is a fitdist object.
I try to estimate the three parameters a, b0 and b1 with the optim() function. But I always get the error:
Error in optim(par = c(1, 1, 1), fn = logweibull, method = "L-BFGS-B", :
L-BFGS-B needs finite values of 'fn'
t<-c(6,6,6,6,7,9,10,10,11,13,16,17,19,20,22,23,25,32,32,34,35,1,1,2,2,3,4,4,5,5,8,8,8,8,11,11,12,12,15,17,22,23)
d<-c(0,1,1,1,1,0,0,1,0,1,1,0,0,0,1,1,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1)
X<-c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
logweibull <- function (a,b0,b1) {a <- v[1];b0 <- v[2]; b1 <- v[3];
sum (d*log(t^a*exp(b0+X*b1)-t^a*exp(b0+X*b1))) + sum (d + log((a*t^(a-1))/t^a)) }
v<-c(1,1,1)
optim( par=c(1,1,1) ,fn = logweibull, method = "L-BFGS-B",lower = c(0.1, 0.1,0.1), upper = c(100, 100,100),control = list(fnscale = -1) )
Can you help me? Do you know what I did wrong?
You may also consider
(1) passing the additional data variables to the objective function along with the parameters you want to estimate.
(2) passing the gradient function (added the gradient function)
(3) the original objective function can be further simplified (as below)
logweibull <- function (v,t,d,X) {
a <- v[1]
b0 <- v[2]
b1 <- v[3]
sum(d*(1+a*log(t)+b0+X*b1) - t^a*exp(b0+X*b1) + log(a/t)) # simplified function
}
grad.logweibull <- function (v,t,d,X) {
a <- v[1]
b0 <- v[2]
b1 <- v[3]
c(sum(d*log(t) - t^a*log(t)*exp(b0+X*b1) + 1/a),
sum(d-t^a*exp(b0+X*b1)),
sum(d*X - t^a*X*exp(b0+X*b1)))
}
optim(par=c(1,1,1), fn = logweibull, gr = grad.logweibull,
method = "L-BFGS-B",
lower = c(0.1, 0.1,0.1),
upper = c(100, 100,100),
control = list(fnscale = -1),
t=t, d=d, X=X)
with output
$par
[1] 0.2604334 0.1000000 0.1000000
$value
[1] -191.5938
$counts
function gradient
10 10
$convergence
[1] 0
$message
[1] "CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH"
Also, below is a comparison between the convergence of with and without gradient function (with finite difference). With an explicit gradient function it takes 9 iterations to converge to the solution, whereas without it (with finite difference), it takes 126 iterations to converge.