I am using a simple polynomial to fit a curve.
poly <- function(a, b, c, x) a * x^2 + b * x + c
I'd like to find the value of x that results in the maximum value of the curve. Currently I create a grid with a range of x from 20000 to 50000, run the function for each row, then use max() on the result. It works, but I have a lot of groups and it creates a big dataframe every time I do it. It is very clunky and I feel like there must be a better way.
Some typical coefficients are:
a <- -0.000000179
b <- 0.011153167
c <- 9.896420781
If you rearrange your function so the variable you want to maximize is first and you set the default values like so:
poly <- function(x, a, b, c) a * x^2 + b * x + c
formals(poly)$a <- -0.000000179
formals(poly)$b <- 0.011153167
formals(poly)$c <- 9.896420781
Then you can use the optimize function to maximize over your interval:
optimize(poly, c(20000, 50000), maximum = T)
$`maximum`
[1] 31154.1
$objective
[1] 183.6298
Where $maximum is the x value at which the maximum occurs and $objective is the height.
If a is negative, maximum of parabola a * x^2 + b * x + c is reached at -b/(2*a) :
a<0
#[1] TRUE
-b/(2*a)
#[1] 31154.1
You could use optim. I think the other solutions answered in this thread are more appealing, but I'll write this up for completeness:
a <- -0.000000179
b <- 0.011153167
c <- 9.896420781
o <- optim(
par=list(x=0),
fn=function(x){ -poly(a,b,c,x=x) },
method="Brent",
lower=-50e3, upper=50e3
)
Output:
> o
$par
[1] 31154.1
$value
[1] -183.6298
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
Related
Suppose I have a function with a kink. I want to derive a kink point, which in this case is 0.314. I tried optim but it does not work.
Here is an example. In general, I want to derive c. Of course, I could use brute force, but it is slow.
# function with a kink
f <- function(x, c){
(x >= 0 & x < c) * 0 + (x >= c & x <=1) * (sin(3*(x-c))) +
(x < 0 | x > 1) * 100
}
# plot
x_vec <- seq(0, 1, .01)
plot(x_vec, f(x_vec, c = pi/10), "l")
# does not work
optim(.4, f, c = pi/10)
This function has no unique minimum.
Here, a trick is to transform this function a little bit, so that its kink becomes a unique minimum.
g <- function (x, c) f(x, c) - x
x_vec <- seq(0, 1, 0.01)
plot(x_vec, g(x_vec, c = pi/10), type = "l")
# now works
optim(0.4, g, c = pi/10, method = "BFGS")
#$par
#[1] 0.3140978
#
#$value
#[1] -0.3140978
#
#$counts
#function gradient
# 34 5
#
#$convergence
#[1] 0
#
#$message
#NULL
Note:
In mathematics, if we want to find something, we have to first define it precisely. So what is a "kink" exactly? In this example, you refer to the parameter c = pi / 10. But what is it in general? Without a clear definition, there is no algorithm/function to get it.
I need to evaluate an integral in the following form:
\int_a^b f(x) \int_0^x g(t)(x-t)dtdx
Can you please suggest a way? I assume that this integral can't be done in the standard approach suggested in the following answer:
Standard approach
Update: Functions are added in the following image. f(x) basically represents a pdf of a uniform distribution but the g(t) is a bit more complicated. a and b can be any positive real numbers.
The domain of integration is a simplex (triangle) with vertices (a,a), (a,b) and (b,b). Use the SimplicialCubature package:
library(SimplicialCubature)
alpha <- 3
beta <- 4
g <- function(t){
((beta/t)^(1/2) + (beta/t)^(3/2)) * exp(-(t/beta + beta/t - 2)/(2*alpha^2)) /
(2*alpha*beta*sqrt(2*pi))
}
a <- 1
b <- 2
h <- function(tx){
t <- tx[1]
x <- tx[2]
g(t) * (x-t)
}
S <- cbind(c(a, a), c(a ,b), c(b, b))
adaptIntegrateSimplex(h, S)
# $integral
# [1] 0.01962547
#
# $estAbsError
# [1] 3.523222e-08
Another way, less efficient and less reliable, is:
InnerFunc <- function(t, x) { g(t) * (x - t) }
InnerIntegral <- Vectorize(function(x) { integrate(InnerFunc, a, x, x = x)$value})
integrate(InnerIntegral, a, b)
# 0.01962547 with absolute error < 2.2e-16
How can I find out the minimum value that can be returned by a function with infinite domain in R?
f <- function(x) { x^2-1 }
print(minVal(f)) # -1
f <- function(x) { x^2+1 }
print(minVal(f)) # 1
So far I've tried optimize, but it requires a finite interval:
minVal <- function(f) {
optimize(f, c(-100, 100))
}
Have you tried the nlm function?
nlm(function(x) x^2 -1, p = 1E3)
$minimum
[1] -1
$estimate
[1] -2.499974e-10
$gradient
[1] 9.995338e-07
$code
[1] 1
$iterations
[1] 1
p is a starting value for minimization that is required.
As well as nlm, you could try
optim(fn=function(x) x^2 -1, par = 1, method="BFGS")
This happens to work with a starting value of 1 or 1000 (although numerical accuracy can almost never be guaranteed for general nonlinear minimization).
This will work even better if you specify the gradient explicitly:
optim(fn=function(x) x^2 -1, gr=function(x) 2*x, par = 1, method="BFGS")
Based on some quick experiment, this seems to give the correct answer for starting values between -10^7 and 10^7.
I'd like to minimize several differences. For one difference, this seems straight forward:
target1 <- 1.887
data <- seq(0,1, by=.001)
#Step 1
somefunction <- function(dat, target1, X){
#some random function...
t <- sum(dat)
y <- t * X
#minimize this difference
diff <- target1-y
return(diff)
}
V1 <- optimize(f = somefunction,
interval = c(0,1),
dat=data,
target1=target,
maximum = T)
V1$maximum
6.610696e-05
#--> This value for `X` should minimize the difference...
V1$maximum * sum(data)
#0.03308653
#--> as close to zero we get
Now, I'd like to minimize several differences in one step relying on optim but this does not work properly:
#Step 2
set.seed(1)
data2 <- data.frame(dat1=seq(0,1, by=.01),
dat2=runif(101),
dat3=runif(101))
somefunction_general <- function(dat, target1, target2, target3, X){
#some random function...
y <- sum(dat[,1]) * X[1]
y1 <- sum(dat[,2]) * X[2]
y2 <- sum(dat[,3]) * X[3]
#minimize these differences...
diff1 <- target1-y
diff2 <- target2-y1
diff3 <- target3-y2
#almost certain that this is wrong...
vtr <- sum(abs(diff1), abs(diff2), abs(diff3))
return(vtr)
}
V2 <- optim(par=c(1,1,1),
fn = somefunction_general,
dat=data2,
target1=1.8,
target2=2,
target3=4,
control = list(fnscale = -1))
sum(data2[,1])
[1] 50.5
sum(data2[,2])
[1] 44.27654
sum(data2[,3])
[1] 51.73668
V2$par[1]*sum(data2[,1])
#[1] 1.469199e+45
V2$par[2]*sum(data2[,2])
#[1] 1.128977e+45
V2$par[3]*sum(data2[,3])
[1] 2.923681e+45
Looks like there's some disagreement between the first function and the second? In the first function, you're returning target1-sum(dat)*X and then trying to find the maximum over X values in [0, 1].
But since you're returning the raw difference and not the absolute value, you're actually just maximizing -sum(dat)*X, or, equivalently, minimizing sum(dat)*X. Since the dat is constant, naturally the optimize function is going to return the smallest value on the interval each time (0 in the example).
For the first function, I think what you want to do is return the absolute value of the difference and then find the minimum and not the maximum. The fix for the second function, somefunction_general, is even simpler, since you're already returning sum(abs(diff1), abs(diff2), abs(diff3)): just make sure the minimum is returned by getting rid of control = list(fnscale = -1)
V2 <- optim(par=c(1,1,1),
fn = somefunction_general,
dat=data2,
target1=1.8,
target2=2,
target3=4)
V2$par
[1] 0.03564358 0.03837754 0.07748929
You should write a function such that whether there is one parameter or more, optim should work on it:
somefunction_general <- function(X, dat, target){
dat <- as.matrix(dat)
y <- colSums(dat) * X
sum((target-y)^2) # Often use the MSE
}
let us test this
data2 <- data.frame(dat1=seq(0,1, by=.01),
dat2=runif(101),
dat3=runif(101))
data <- seq(0,1, by=.001)
(a <-optim(0,somefunction_general,dat = data,target = 1.887,method = "BFGS"))
$par
[1] 0.00377023
$value
[1] 3.64651e-28
$counts
function gradient
25 3
$convergence
[1] 0
$message
NULL
We can not that the function value is zero. thus the parameter a$par is what we want. check this out
a$par*sum(data)
[1] 1.887
We can also have 3 parameters 1 target eg:
(b<-optim(c(0,0,0),somefunction_general,dat = data2,target = 1.887))
$par
[1] 0.03736837 0.04262253 0.03647203
$value
[1] 4.579334e-08
$counts
function gradient
100 NA
$convergence
[1] 0
$message
NULL
b$par*colSums(data2)
dat1 dat2 dat3
1.887103 1.887178 1.886942
Each almost got to the target of 1.887. note that this is similar to running the first one 3 times.
lastly:
(d<-optim(c(0,0,0),somefunction_general,dat = data2,target = c(1.8, 2, 4)))
$par
[1] 0.03564672 0.04516916 0.07730660
$value
[1] 2.004725e-07
$counts
function gradient
88 NA
$convergence
[1] 0
$message
NULL
the target was achieved:
d$par*colSums(data2)
dat1 dat2 dat3
1.800160 1.999934 3.999587
This one function can work on n dimensions. please use the method BFGS unless it does not converge.
What if there is one parameter with three targets? well this is quite difficult. Unless there is such a parameter, then it wont converge.
suppose we say the parameter is 0.01, what is the target?
colSums(data2)*0.01
dat1 dat2 dat3
0.5050000 0.4427654 0.5173668
Okay, suppose we were given this target, can we get the 0.01 back?
(e<-optim(10,somefunction_general,dat = data2,target = c(0.505, 0.4427654, 0.5173668),method = "BFGS"))
$par
[1] 0.01
$value
[1] 7.485697e-16
$counts
function gradient
12 3
$convergence
[1] 0
$message
NULL
Huh, we were able to converge. this is because there was a parameter that could take us there. note that i did change the starting point to 10.
Suppose I have the following system of equations:
a * b = 5
sqrt(a * b^2) = 10
How can I solve these equations for a and b in R ?
I guess this problem can be stated as an optimisation problem, with the following function... ?
fn <- function(a, b) {
rate <- a * b
shape <- sqrt(a * b^2)
return(c(rate, shape) )
}
In a comment the poster specifically asks about using solve and optim so we show how to solve this (1) by hand, (2) using solve, (3) using optim and (4) a fixed point iteration.
1) by hand First note that if we write a = 5/b based on the first equation and substitute that into the second equation we get sqrt(5/b * b^2) = sqrt(5 * b) = 10 so b = 20 and a = 0.25.
2) solve Regarding the use of solve these equations can be transformed into linear form by taking the log of both sides giving:
log(a) + log(b) = log(5)
0.5 * (loga + 2 * log(b)) = log(10)
which can be expressed as:
m <- matrix(c(1, .5, 1, 1), 2)
exp(solve(m, log(c(5, 10))))
## [1] 0.25 20.00
3) optim Using optim we can write this where fn is from the question. fn2 is formed by subtracting off the RHS of the equations and using crossprod to form the sum of squares.
fn2 <- function(x) crossprod( fn(x[1], x[2]) - c(5, 10))
optim(c(1, 1), fn2)
giving:
$par
[1] 0.2500805 19.9958117
$value
[1] 5.51508e-07
$counts
function gradient
97 NA
$convergence
[1] 0
$message
NULL
4) fixed point For this one rewrite the equations in a fixed point form, i.e. in the form c(a, b) = f(c(a, b)) and then iterate. In general, there will be several ways to do this and not all of them will converge but in this case this seems to work. We use starting values of 1 for both a and b and divide both side of the first equation by b to get the first equation in fixed point form and we divide both sides of the second equation by sqrt(a) to get the second equation in fixed point form:
a <- b <- 1 # starting values
for(i in 1:100) {
a = 5 / b
b = 10 / sqrt(a)
}
data.frame(a, b)
## a b
## 1 0.25 20
Use this library.
library("nleqslv")
You need to define the multivariate function you want to solve for.
fn <- function(x) {
rate <- x[1] * x[2] - 5
shape <- sqrt(x[1] * x[2]^2) - 10
return(c(rate, shape))
}
Then you're good to go.
nleqslv(c(1,5), fn)
Always look at the detailed results. Numerical calculations can be tricky. In this case I got this:
Warning message:
In sqrt(x[1] * x[2]^2) : NaNs produced
That just means the procedure searched a region that included x[1] < 0 and then presumably noped the heck back to the right hand side of the plane.