I am solving a nonlinear equation using the package nleqslv, but I keep getting the error: Length of fn result <> length of x!
I can't spot the place where vector length can be a problem. Anyone knows what mistakes did I made in my code?
library(nleqslv)
d_plus <- function(x) (log(55.75/x[1])+(0.026 + x[2]^2 / 2) * 0.25) / (x[2]*0.5) + 0 * x[3]
d_minus <- function(x) (log(55.75/x[1])+(0.026 - x[2]^2 / 2) * 0.25) / (x[2]*0.5) + 0 * x[3]
F_C0 <- function(x) 55.75 * pnorm(d_plus(x)) - x[1] * exp(-0.026 * 0.25) * pnorm(d_minus(x)) + 0 * x[3]
eqn <- function(x) F_C0(x) - x[3]
nleqslv( c(40, 1, 17.35), eqn)
I am trying to solve for x[2] and I have the input of x[1] and x[3]. It looks like I should get the numeric solution of x[2].
Your example is not reproducible since you have not shown all your code: library(nleqslv) is missing. Please show all your code.
As the first comment on your question stated you are providing a vector to eqn but functions d_plus, d_minus and thus F_C0 return a scalar.
That implies that the length of the function result is not the same as the length of the input.
From your explanation you want to solve for x[2]. So the function presented to nleqslv must take a scalar as input and return a scalar.
This can be achieved as follows:
library(nleqslv)
d_plus <- function(x) (log(55.75/x[1])+(0.026 + x[2]^2 / 2) * 0.25) / (x[2]*0.5) + 0 * x[3]
d_minus <- function(x) (log(55.75/x[1])+(0.026 - x[2]^2 / 2) * 0.25) / (x[2]*0.5) + 0 * x[3]
F_C0 <- function(x) 55.75 * pnorm(d_plus(x)) - x[1] * exp(-0.026 * 0.25) * pnorm(d_minus(x)) + 0 * x[3]
eqn <- function(xpar) { x <- c(40,xpar,17.35);F_C0(x) - x[3] }
Insert the scalar argument of eqn, which is your x[2], into a vector x where the first and third entries are what you provided as starting values in your code .
Then running this
xstart <- 1
nleqslv( xstart, eqn)
results in this
$x
[1] 0.6815036
$fvec
[1] 6.18563e-11
$termcd
[1] 1
$message
[1] "Function criterion near zero"
$scalex
[1] 1
$nfcnt
[1] 5
$njcnt
[1] 1
$iter
[1] 5
Read the documentation of nleqslv to see what these items mean.
As you can see nleqslv found a solution to your problem.
Related
#generating 100 uniformly distributed numbers
u1 <- runif(100,0,1)
u2 <- runif(100,0,1)
x1 <- function(x, y) {
return(sqrt(-2 * log(x) * cos(2 * pi * y)))
}
x2 <- function(x, y) {
return(sqrt(-2 * log(x) * sin(2 * pi * y)))
}
#applying x1
x1_vals <- mapply(x1, u1, u2)
#applying x2
x2_vals <- mapply(x2, u1, u2)
Hi I want to write a box muller function, this is part of my attempt above, I'm trying to avoid using loops as much as possible(for loops especially)
However, I keep getting NA values for my x1/x2 functions. I can't figure out whats wrong.
Here is the Box-Muller formula corrected.
x1 <- function(x, y) sqrt(-2 * log(x)) * cos(2 * pi * y)
x2 <- function(x, y) sqrt(-2 * log(x)) * sin(2 * pi * y)
u1 <- runif(1000,0,1)
u2 <- runif(1000,0,1)
# applying x1
x1_vals <- x1(u1, u2)
all(is.finite(x1_vals))
#> [1] TRUE
# applying x2
x2_vals <- x2(u1, u2)
all(is.finite(x2_vals))
#> [1] TRUE
old_par <- par(mfrow = c(1, 2))
hist(x1_vals, freq = FALSE)
curve(dnorm, from = -4, to = 4, add = TRUE)
hist(x2_vals, freq = FALSE)
curve(dnorm, from = -4, to = 4, add = TRUE)
par(old_par)
Created on 2022-09-28 with reprex v2.0.2
Those functions are already vectorized. Don't need to wrap mapply around them. Just give the two vectors to x1 and x2
x1(u1,u2)
[1] NaN NaN NaN NaN 0.3088330
[6] NaN 0.7866889 NaN NaN 1.7102801
[11] 2.1886770 NaN 1.5473627 1.0644378 0.8499208
snipped remaining 100 values
Vectorization is a feature of the R language. If the expressions in the function body can all take vectors and return vectors of equal length then no loop wrapper is needed.
You are getting NA's because the domain of the arguments to sin and cos are causing both positive and negative values to be given to sqrt.
I need to find exact and numerical solutions to a function but my code in R shows Error in optim(start_val[i, ], g) :
function cannot be evaluated at initial parameters
that is my code:
g <- function(x) (3*x[1]+2*x[2]+4*x[3]-4)^2 + (4*x[1]+2*x[2]+4*x[3]-2)^2 + (1*x[1]+1*x[2]+4*x[3]-4)^2
start_val <- expand.grid(c(-10,0,10),c(-10,0,10),c(-10,0,10))
optim_on_a_multiple_grid <- function(start_val, fun, ...) {
opt_result <- sapply(1:nrow(start_val),
function(i) {
res <- optim(start_val[i,], g)
c(res[[1]], res[[2]], res[[4]])
})
rownames(opt_result) <-
c(paste("x_", 1:ncol(start_val),
"_start_val", sep = ""),
paste("x_", 1:ncol(start_val),
"_sol", sep = ""),
paste(c(deparse(substitute(
fun
)), "_min"), collapse = ""),
"convergence")
opt_result
}
round(optim_on_a_multiple_grid(expand.grid(c(-10, 0, 10), c(-10, 0, 10)), g), 3)
Please, point me at my mistakes and explain how to fix them, I am stuck on it for quite a while now
I do not know why you have alot of objects while your aim is to optimize:
Do
# Define g
g <- function(x){
a <- (3 * x[1] + 2 * x[2] + 4 * x[3] - 4)^2
b <- (4 * x[1] + 2 * x[2] + 4*x[3] - 2)^2
d <- (x[1] + x[2] + 4*x[3] - 4)^2
a +b +d
}
optim(par=c(0,0,1), fn=g)
$par
[1] -1.9998762 3.9996836 0.5000453
$value
[1] 8.468819e-09
$counts
function gradient
160 NA
$convergence
[1] 0
$message
NULL
If you need your code:
The problem lies at the very end of it:
You should have:
round(optim_on_a_multiple_grid(start_val, g), 3)
I am using the R programming language. Using the "optim" library and the "BFGS" optimization algorithm, I am interested in optimizing the following function (also called the "Rosenbrock Function"):
If you define this function and the derivative of this function, it is pretty straightforward to optimize with the "optim" library and the BFGS algorithm (note: the BFGS algorithm requires knowledge of the function's derivative):
fr <- function(x) { ## Rosenbrock Banana function
x1 <- x[1]
x2 <- x[2]
100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}
grr <- function(x) { ## Gradient of 'fr'
x1 <- x[1]
x2 <- x[2]
c(-400 * x1 * (x2 - x1 * x1) - 2 * (1 - x1),
200 * (x2 - x1 * x1))
}
res <- optim(c(-1.2,1), fr, grr, method = "BFGS")
> res
$par
[1] 1 1
$value
[1] 9.594956e-18
$counts
function gradient
110 43
$convergence
[1] 0
$message
NULL
Suppose you are working with a high dimensional complicated function - the derivative of this function will be difficult to manually evaluate and then write a function for this derivative (i.e. an additional place where you can make a mistake). Are there any "automatic" ways in R, such that if you write a mathematical function - R can automatically "infer" the derivative of this function?
For instance, in a new R session - would there have been some way to run the BFGS algorithm without explicitly defining the derivative?
fr <- function(x) { ## Rosenbrock Banana function
x1 <- x[1]
x2 <- x[2]
100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}
#pseudo code
res <- optim(c(-1.2,1), fr, ??? , method = "BFGS")
Does anyone know if something like this is possible? Can R automatically infer the derivative?
I thought of an approach where you could use a preexisting "numerical differentiation" function in R to approximate the derivative at each iteration, and then feed this approximation into the BFGS algorithm, but that sounds very complicated and unnecessary.
It would have been nice if R could somehow automatically infer the derivative of a function.
References:
https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/optim
This is already built into the optim() function. If you don't specify the derivative it will be calculated numerically e.g.
fr <- function(x) { ## Rosenbrock Banana function
x1 <- x[1]
x2 <- x[2]
100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}
optim(c(-1.2,1), fr, method = "BFGS")
# $par
# [1] 0.9998044 0.9996084
#
# $value
# [1] 3.827383e-08
#
# $counts
# function gradient
# 118 38
#
# $convergence
# [1] 0
#
# $message
# NULL
Note that (at least for this case) the solution is very close to that found using the analytical derivatives.
I'm trying to solve a simple system of non-linear equations described in this post.
The system is two equations with two unknowns p and q and a free parameter lambda:
When lambda = 1 the system looks like this:
There is a unique solution and it's in the vicinity of p = 0.3, q = 0.1.
I'm trying to solve it with nleqslv. My objective function is:
library(nleqslv)
fn = function(x, lambda = 1){
# p = x[1]
# q = x[2]
pstar = exp(lambda * (1*x[2])) / (exp(lambda * (1*x[2])) + exp(lambda * (1 - x[2])))
qstar = exp(lambda * (1 - x[1])) / (exp(lambda * ((1 - x[1]))) + exp(lambda * (9*x[1])))
return(c(pstar,qstar))
}
but the results don't match what the plot:
> xstart = c(0.1, 0.3)
> nleqslv(xstart, fn)$x
[1] 1.994155 -8.921285
My first question is: am I using nleqslv correctly? I thought so after looking at other examples. But now I'm not sure.
My second question: is this a good problem nleqslv? Or am I barking up the wrong tree?
Your function does not reflect properly what you want.
You can see this by evaluating fn(c(0.3,0.1)) as follows.
fn(c(0.3,0.1))
[1] 0.3100255 0.1192029
So the output is very close to the input. You wanted (almost) zero as output.
So you want to solve the system for p and q.
What you need to do is to make your function return the difference between the input p and the expression for pstar and the difference between the input q and the expression for qstar.
So rewrite your function as follows
fn <- function(x, lambda = 1){
p <- x[1]
q <- x[2]
pstar <- exp(lambda * (1*x[2])) / (exp(lambda * (1*x[2])) + exp(lambda * (1 - x[2])))
qstar <- exp(lambda * (1 - x[1])) / (exp(lambda * ((1 - x[1]))) + exp(lambda * (9*x[1])))
return(c(pstar-p,qstar-q))
}
and then call nleqslv as follows (PLEASE always show all the code you are using. You left out the library(nleqslv)).
library(nleqslv)
xstart <- c(0.1, 0.3)
nleqslv(xstart, fn)
This will display the full output of the function. Always a good idea to check for succes. Always check $termcd for succes.
$x
[1] 0.3127804 0.1064237
$fvec
[1] 5.070055e-11 6.547240e-09
$termcd
[1] 1
$message
[1] "Function criterion near zero"
$scalex
[1] 1 1
$nfcnt
[1] 7
$njcnt
[1] 1
$iter
[1] 7
The result for $x is more what you expect.
Finally please use <- for assignment. If you don't there will come the day that you will be bitten by R and its magic.
This is nothing wrong in using nleqslv for this problem. You only made a small mistake.
I have 2 equation that need to be solved by using optim
{(4x^2-20x+1/4 y^2+8=0
1/2 xy^2+2x-5y+8=0)
I have already run the code,but I'm confused if there should be 1 answer or 2 because function will only return the results for the last line
Should I do like this
> myfunc=function(x){
+ 4*x[1]^2-20*x[1]+(x[2]^2/4)+8
+ }
> optim(c(0,0),myfunc,method="BFGS")
and
> myfunc=function(x){
+ (1/2)*(x[1]*x[2]^2)+2*x[1]-5*x[2]+8
+ }
> optim(c(0,0),myfunc,method="BFGS")
or should I do like this
> myfunc=function(x){
+ 4*x[1]^2-20*x[1]+(x[2]^2/4)+8
+ (1/2)*(x[1]*x[2]^2)+2*x[1]-5*x[2]+8
+ }
> optim(c(0,0),myfunc,method="BFGS")
For the second one it still give me only the answer for the second function so which method is correct.
Minimize the sum of the squares of the two expressions that should equal zero and ensure that the value at the optimum equals 0 (up to floating point approximation).
myfunc <- function(z) {
x <- z[1]
y <- z[2]
(4*x^2-20* x + 1/4*y^2 + 8)^2 + (1/2 * x*y^2 + 2*x- 5*y + 8)^2
}
optim(c(0, 0), myfunc)
giving:
$par
[1] 0.5000553 2.0002986
$value
[1] 1.291233e-06
$counts
function gradient
67 NA
$convergence
[1] 0
$message
NULL
You can also use a package for solving systems of non linear equations such as nleqslv.
Slightly redefine your function by making it return a vector containing the result for each equation
myfunc <- function(x){
y <- numeric(length(x))
y[1] <- 4*x[1]^2-20*x[1]+(x[2]^2/4)+8
y[2] <- (1/2)*(x[1]*x[2]^2)+2*x[1]-5*x[2]+8
y
}
Define a starting value for the solver
xstart <- c(0,0)
Then do this
library(nleqslv)
nleqslv(xstart,myfunc)
giving
$x
[1] 0.5 2.0
$fvec
[1] -1.472252e-09 -7.081979e-10
$termcd
[1] 1
$message
[1] "Function criterion near zero"
$scalex
[1] 1 1
$nfcnt
[1] 7
$njcnt
[1] 1
$iter
[1] 7
There are more packages that can solve equation systems such as BB and pracma.