In R , I have a vector like x= 3:100
I want to write function like:
sum ( (x/a)^2t) - 5
and get the answer if I choose any value for t .
Example:
Func= function ( t ) {
x=c(1:100)
a= min(x)
Sum ( x / a )^2t - 5
}
I don't know if this correct or not.
what about if I want to get the root of the function by secant method. I use library(NLRoot) in R. but the codes that I write it is not correct.
library(NLRoot)
curve(func, xlim=c(0,3), col='blue', lwd=1.5, lty=2,xlab="x",ylab="f(x)")
output is written Error in code.
Here is just a syntax correction
Func <- function(t) {
x <- c(1:100)
a <- min(x)
sum((x / a)^(2 * t)) - 5
}
and a more compact version might be something like below
Func <- function(t, x = 1:100) sum((x / min(x))^(2 * t)) - 5
To find the root, thanks for comments from #Rui Barradas, we can use uniroot, i.e.,
> uniroot(Func, interval = c(-5, 5))
$root
[1] -0.5091492
$f.root
[1] -0.0003913713
$iter
[1] 13
$init.it
[1] NA
$estim.prec
[1] 6.103516e-05
Related
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'm trying to solve this equation: ((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) =1
Is there a way to do this with R?
ATTEMPT with incorrect solution:
library(Ryacas)
eq <- "((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 "
# simplify the equation:
library(glue)
yac_str(glue("Simplify({eq})"))
library(evaluate)
evaluate(eq,list(x=c(0,1,10,100,-100)))
evaluate() just returns the equation:
"((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 "
The answer for the equation is −2004200
It sounds like you want to Solve() for x rather than merely simplifying ... ? The following code solves the equation, strips off the x== from the solution, and evaluates the expression:
eq2 <- gsub("x==","",yac_str(glue("Solve({eq},x)")))
[1] "{(-0.80168e6)/0.4}"
eval(parse(text=eq2))
[1] -2004200
1) Ryacas Use the Ryacas package solve as shown below. (Thanks to #mikldk for improvement to last line.)
library(Ryacas)
eq <- "((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 " # from question
res <- solve(ysym(eq), "x")
as_r(y_rmvars(res)) # extract and convert to R
## [1] -2004200
if eq has R variables in it, here h is referenced in eq2, then use eval to evaluate the result.
h <- 2300
eq2 <- "((h+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 " # from question
res2 <- solve(ysym(eq2), "x")
eval(as_r(y_rmvars(res2)))
## [1] -2004200
2) Ryacas0 or using eq from above with the Ryacas0 package:
library(Ryacas0)
res <- Solve(eq, "x")
eval(Expr(res)[[1:3]]) # convert to R
## [1] -2004200
3a) Base R In light of the fact that this is a linear equation and the solution to the following where A is the slope and B is the intercept:
A * x + B = 0
is
x = - B / A
if we replace x with the imaginary 1i and then move the rhs to the lhs we have that B and A are the real and imaginary parts of that expression. No packages are used.
r <- eval(parse(text = sub("==", "-", eq)), list(x = 1i))
-Re(r) / Im(r)
## [1] -2004200
3b) If we move the rhs to lhs then B equals it at x=0 and A equals the derivative wrt x so another base R solution would be:
e <- parse(text = sub("==", "-", eq))
- eval(e, list(x = 0)) / eval(D(e, "x"))
## [1] -200420
Here is a base R solution.
Rewrite the equation in the form of a function, use curve to get two end points where the function has different signs and put uniroot to work.
f <- function(x) ((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) - 1
curve(f, -1e7, 1)
uniroot(f, c(-1e7, 1))
#$root
#[1] -2004200
#
#$f.root
#[1] 0
#
#$iter
#[1] 1
#
#$init.it
#[1] NA
#
#$estim.prec
#[1] 7995800
Following the discussion in the comments to the question, here is a general solution. The function whose roots are to be found now accepts an argument params in order to pass the values of rent, salary, number of workers, price, unit cost and capital cost. This argument must be a named list.
f <- function(x, K = 1, params) {
A <- with(params, rent + salary*workers)
with(params, (A + (x + A)*capitalcost)/(price - unitcost) - K)
}
params <- list(
rent = 2300,
salary = 1900,
workers = 1,
price = 600,
unitcost = 400,
capitalcost = 0.002
)
curve(f(x, params = params), -1e7, 1)
uniroot(f, c(-1e7, 1), params = params)
If you want something quick: rootSolve library is your go-to.
library(rootSolve)
func_ <- function(x) ((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400)-1
uniroot.all(func_, c(-1e9, 1e9))
[1] -2004200
Note that most of the time reducing the interval is better.
If you will maintain the same structure, then in Base R, you could do:
solveX <- function(eq){
U <- function(x)abs(eval(parse(text = sub("=+","-", eq)), list(x=x)))
optim(0, U, method = "L-BFGS-B")$par
}
eq <- "((2300+1900*1)+(x+2300+1900*1)*0.002)/(600-400) ==1 "
solveX(eq)
[1] -2004200
I fear I get something really wrong. The basics are from here
and a basic (minimal) example is understood (I think) and working:
fun.default <- function(x) { # you could add further fun.class1 (works)...
print("default")
return(x[1] + x[2])
}
my_fun <- function(x) {
print("my_fun")
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun...")
return(res)
}
x <- c(1, 2)
my_fun(x)
However, if I want to add parameters, something goes really wrong. Form the link above:
Once UseMethod has found the correct method, it’s invoked in a special
way. Rather than creating a new evaluation environment, it uses the
environment of the current function call (the call to the generic), so
any assignments or evaluations that were made before the call to
UseMethod will be accessible to the method.
I tried all variants I could think of:
my_fun_wrong1 <- function(x, y) {
print("my_fun_wrong1")
print(x)
x <- x + y
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun_wrong1...")
return(res)
}
x <- c(1, 2)
# Throws: Error in fun.default(x, y = 2) : unused argument (y = 2)
my_fun_wrong1(x, y = 2)
my_fun_wrong2 <- function(x) {
print("my_fun_wrong2")
print(x)
x <- x + y
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun_wrong2...")
return(res)
}
x <- c(1, 2)
y = 2
# Does not throw an error, but does not give my expetced result "7":
my_fun_wrong2(x) # wrong result!?
rm(y)
my_fun_wrong3 <- function(x, ...) {
print("my_fun_wrong3")
print(x)
x <- x + y
print(x)
res <- UseMethod("fun", x)
print(res)
print("END my_fun_wrong3...")
return(res)
}
x <- c(1, 2)
# Throws: Error in my_fun_wrong3(x, y = 2) : object 'y' not found
my_fun_wrong3(x, y = 2)
Edit after answer G. Grothendieck: Using fun.default <- function(x, ...) I get
Runs after change, but I don't understand the result:
my_fun_wrong1(x, y = 2)
[1] "my_fun_wrong1"
[1] 1 2
[1] 3 4 # Ok
[1] "default"
[1] 3 # I excpect 7
As before - I don't understand the result:
my_fun_wrong2(x) # wrong result!?
[1] "my_fun_wrong2"
[1] 1 2
[1] 3 4 # Ok!
[1] "default"
[1] 3 # 3 + 4 = 7?
Still throws an error:
my_fun_wrong3(x, y = 2)
[1] "my_fun_wrong3"
[1] 1 2
Error in my_fun_wrong3(x, y = 2) : object 'y' not found
I think, this question is really useful!
fun.default needs ... so that the extra argument is matched.
fun.default <- function(x, ...) {
print("default")
return(x[1] + x[2])
}
x <- c(1, 2)
my_fun_wrong1(x, y = 2)
## [1] "my_fun_wrong1"
## [1] 1 2
## [1] 5 6
## [1] 3
Also, any statements after the call to UseMethod in the generic will not be evaluated as UseMethoddoes not return so it is pointless to put code after it in the generic.
Furthermore, you can't redefine the arguments to UseMethod. The arguments are passed on as they came in.
Suggest going over the help file ?UseMethod although admittedly it can be difficult to read.
Regarding the quote from ?UseMethod that was added to the question, this just means that the methods can access local variables defined in the function calling UseMethod. It does not mean that you can redefine arguments. Below ff.default refers to the a defined in ff.
a <- 0
ff <- function(x, ...) { a <- 1; UseMethod("ff") }
ff.default <- function(x, ...) a
ff(3)
## [1] 1
I have this equation to solve (e.g. f(x,y) = 0):
library(nleqslv)
target <- function(x)
{
z = x[1]/(x[1]+x[2])
y = numeric(2)
y[1] <- z*exp(-x[2]*(x[2]+z*(1-exp(-x[1]/z))))-0.00680
y[2] <- z/x[2]*(1-exp(-x[2]))-exp(-x[2])*z/x[1]*(1-exp(-x[1]))-3.43164
y
}
# Usage
xstart <- c(1,1)
target(xstart)
nleqslv(xstart, target, control=list(ftol=.0001, allowSingular=TRUE),jacobian=TRUE,method="Newton")
using R with nleqslv or another you have others :)
Thanks
I have been experimenting with your function. Rewrite the target function to use the a;b constants in your comment as in your second comment as follows:
target <- function(x, a=.00680,b=3.43164)
{
z <- x[1]/(x[1]+x[2])
y <- numeric(2)
y[1] <- z*exp(-x[2]*(x[2]+z*(1-exp(-x[1]/z))))-a
y[2] <- z/x[2]*(1-exp(-x[2]))-exp(-x[2])*z/x[1]*(1-exp(-x[1]))-b
y
}
The default values for a and b are what you initially specified.
Using them you'll get an ill-conditioned jacobiam.
However if we give some other values to a and b for example like so
nleqslv(xstart, target, control=list(btol=.01),jacobian=TRUE,method="Newton",a=2,b=1)
or
nleqslv(xstart, target, control=list(btol=.01),jacobian=TRUE,method="Newton",a=2,b=2)
then for the first expression the full return value of nleqslv is
$x
[1] 2.4024092 -0.7498464
$fvec
[1] 1.332268e-15 2.220446e-16
$termcd
[1] 1
$message
[1] "Function criterion near zero"
$scalex
[1] 1 1
$nfcnt
[1] 10
$njcnt
[1] 7
$iter
[1] 7
$jac
[,1] [,2]
[1,] -0.2930082 -1.2103174
[2,] 0.1801120 -0.6566861
I am inclined to conclude that either your function is incorrect or that you have specified impossible values for a and b. Method Broyden also seems to work nicely.
I'm trying to solve
$\sum_{j=1}^{180} x^{a_j} = 1$
I created two functions :
f1 <- function(x){c(rep(x,180))}
f2 <- function(x){sum(f1(x)^vec) - 1}
where vec is my a_j vector.
uniroot doesn't work. Which function should I use ?
Is there a better syntax ?
Why doesn't uniroot work, actually? As long as you define correctly your function and the interval to look for it should work:
aj <- c(-4,-5,-3,-4,-2,-3,-1,-2,-7,-6,-5,-8,-7,-6,-6,-7,-5,-6,
-4,-5,-3,-4,-9,-8,-7,-10,-9,-8,-1,-2,rep(-1,150))
f <- function(x,vec){sum(x^vec)-1}
uniroot(f, interval=c(-100,100), vec=aj)
$root
[1] -0.518658
$f.root
[1] -0.009276057
$iter
[1] 21
$estim.prec
[1] 6.103516e-05
You can use polyroot, For example
polyroot(c(-1,rep(1,180)))
here
p(x) = -1 + 1 * x + … + 1 * x^180
EDIT To use your vector aj
It is not clear what is your vector vec , I guess you want something like this :
polyroot(c(-1,vec))
Where vec
vec = (a1,a2,..............,a180)
EDIT after OP clarification:
The OP wants to find the roots of polynome with negative exponents. The solution is to factorize by the max of the exponents to can apply polyroot.
vec <- c(-4,-5,-3,-4,-2,-3,-1,-2,-7,-6,-5,-8,-7,-6,-6,-7,-5,-6,
-4,-5,-3,-4,-9,-8,-7,-10,-9,-8,-1,-2,rep(-1,150))
ma <- max(abs(vec))
vec <- sort(ma+vec)
polyroot(as.data.frame(table(vec))$Freq)