Solve simple equation in R - r

I have a probably really basic question concerning the possibility to solve functions in R, but to know the answer would really help to understand R better.
I have following equation:
0=-100/(1+r)+(100-50)/(1+r)^2+(100-50)/(1+r)^3+...(100-50)/(1+r)^10
How can I solve this equation in R finding the variable r?
I tried sth. like this:
n <- c(2:10)
0 = -100/(r+1)+sum((100-50)/((1+r)^n))
But got an error message:
Error in 0 = -100/(r + 1) + sum((100 - 50)/((1 + r)^n)) :
invalid (do_set) left-hand side to assignment
What's the problem and how can I find r?

There are plenty of optimization and root finding libraries for R link here. But in native R:
fnToFindRoot = function(r) {
n <- c(2:10)
return(abs(-100/(r+1)+sum((100-50)/((1+r)^n))))
}
# arbitrary starting values
r0 = 0
# minimise the function to get the parameter estimates
rootSearch = optim(r0, fnToFindRoot,method = 'BFGS', hessian=TRUE)
str(rootSearch)
fnToFindRoot(rootSearch$par)
That function is very volatile. If you are willing to bracket the root, you are probably better off with uniroot:
fnToFindRoot = function(r,a) {
n <- c(2:10)
return((-100/(r+1)+sum((100-50)/((1+r)^n)))-a)
}
str(xmin <- uniroot(fnToFindRoot, c(-1E6, 1E6), tol = 0.0001, a = 0))
The a argument is there so you can look for a root to any arbitrary value.

Try bisection. This converges to r = 0.4858343 in 25 iterations:
library(pracma)
bisect(function(r) -100/(1+r) + sum(50/(r+1)^seq(2, 10)), 0, 1)
giving:
$root
[1] 0.4858343
$f.root
[1] 8.377009e-07
$iter
[1] 25
$estim.prec
[1] 1.490116e-08

Let x = 1/(1+r), so your equation should be:
0-100x + 50x^2 + 50x^3 + ... + 50x^10 = 0.
then in R:
x <- polyroot(c(0, -100, rep(50, 9)))
(r <- 1/x - 1)
Here is the answer:
[1] Inf+ NaNi 0.4858344-0.0000000i -1.7964189-0.2778635i
[4] -0.3397136+0.6409961i -0.3397136-0.6409961i -1.4553556-0.7216708i
[7] -0.9014291+0.8702213i -0.9014291-0.8702213i -1.7964189+0.2778635i
[10] -1.4553556+0.7216708i

Related

How can I solve easy linear equations with minimization problem in R?

I have following Inputs:
Inputs <- seq(2,7.7,0.3)
Weights <- paste("w",sep="_",seq(1:20))
And the following equations:
sum(Weights * Inputs) == 4.8
sum(Weights) == 1
min(sum(Weights^2))
Can someone explain how I get a solution for Weights? Thanks!
You can use the optim function. This relies on being able to specify a function that produces a single scalar output which is minimized when the conditions are met. In your case, the function might look like this:
constraints <- function(W) (sum(W * Inputs) - 4.8)^2 + (sum(Weights) - 1)^2
So to solve it we can do:
Weights <- optim(rep(0.05, 20), constraints, method = "BFGS")$par
Which gives us the following result:
Weights
#> [1] 0.04981143 0.04978314 0.04975486 0.04972657 0.04969828 0.04967000 0.04964171
#> [8] 0.04961343 0.04958514 0.04955685 0.04952857 0.04950028 0.04947200 0.04944371
#> [15] 0.04941543 0.04938714 0.04935885 0.04933057 0.04930228 0.04927400
sum(Weights * Inputs)
#> [1] 4.8
sum(Weights)
#> [1] 0.9908542
Obviously, this is a numeric optimization with a 20-dimensional input, so it doesn't perfectly converge to a sum of 1 with the given starting values.

No sign change found error in R but not excel

Just trying to understand why when I find the root of the following equation in excel I get a value however in R I get the "no sign change found error"
(-exp(-i*x))-x + 1
i = 1 in this case.
I'm plotting a graph where the value for i is 1:5. I've done this manually on excel and got a value of 0.003 when i = 1, here is the graph for all values of i: image 1
When try to find the root for when i = 1 in R though I get the error.
This is the code I am using to find the root:
func1 <- function(x) {
(-exp(-1*x))-x+1
}
root <- uniroot(func1, lower =0.5, upper = 1, extendInt = "yes")
print(root)
print(root$root)
}
Plotting the equation when i = 1 gives the following curve: image 2
Looking at the curve it doesn't seem like f(x) crosses 0 which explains the error, however, I get a value in excel.
Any help on this would be really appreciated
Thanks
This is the best I can offer. It is using a method of derivatives I found at http://rpubs.com/wkmor1/simple-derivatives-in-r. It will allow you to get the roots from newtons method.
options(scipen = 999)
f<-function(x) (-exp(-x)-x+1)
g<-function(x) { }
body(g)<-D(body(f),"x")
x <- 19
y<-vector()
y[1]<-x
for(i in 2:500) {
y<-c(y, y[i-1] - (f(y[i-1])/g(y[i-1])))
if(y[i]==y[i-1]) break
}
y
The output looks like this:
> y
[1] 19.000000000000000 0.999999893546867 0.418023257075328 0.194491909332762
[5] 0.094095681658666 0.046310116577025 0.022976345768161 0.011444180565743
[9] 0.005711176200954 0.002852869974152 0.001425756748278 0.000712708975595
[13] 0.000356312158327 0.000178145499021 0.000089070105497 0.000044534390909
[17] 0.000022267031356 0.000011133470771 0.000005566723944 0.000002783342584
[21] 0.000001391644148 0.000000695821730 0.000000347990248 0.000000173795172
[25] 0.000000086916841 0.000000043487300 0.000000023063442 0.000000013435885
[29] -0.000000003090351 -0.000000003090351
I hope this helps.

Using for loop variable to access element in array yielding NA in R

I'm using a nested for loop to create a greedy algorithm in R.
z = 0
for (j in 1:length(t))
for (i in 1:(length(t) - j))
if ((t[j + i] - t[j]) >= 30)
{z <- c(z,j + i - 1)
j <- j + i - 1
break}
z
Where t is a vector such as:
[1] 12.01485 26.94091 33.32458 49.46742 65.07425 76.05700
[7] 87.11043 100.64116 111.72977 125.72649 139.46460 153.67292
[13] 171.46393 184.54244 201.20850 214.05093 224.16196 237.12485
[19] 251.51753 258.45865 273.95466 285.42704 299.01869 312.35587
[25] 326.26289 339.78724 353.81854 363.15847 378.89307 390.66134
[31] 402.22007 412.86049 424.23181 438.50462 448.88005 462.59917
[37] 473.65289 487.20678 499.80053 509.14141 526.03873 540.17209
[43] 550.69941 565.74602 576.06882 589.07297 598.53208 614.20677
[49] 627.44605 648.08346 665.49614 681.46445 691.01806 704.05762
[55] 714.09172 732.04124 745.90960 758.52628 769.80519 779.41537
[61] 788.35732 805.78547 818.75262 832.71196 844.97859 856.08608
[67] 865.72998 875.55945 887.20862 900.00000
The goal for the function is to find the indexes whose differences are as close to 30 as possible and save them in z.
For example, with the vector t provided, I would expect z to be [0, 2, 4, 6, 8, 10,...70]
The functionality is not my concern right now, as I am running into the error:
Error in if ((t[j + i] - t[j]) >= 30) { :
missing value where TRUE/FALSE needed
I'm new to R so I know I'm not utilizing the vectorization that R is known for. I simply want to have 'j' and 'i' as "counter variables" that I can use to access specific elements of vector t, but for a reason unknown to me, the if statement is not yielding a T/F value.
Any suggestions?
I know you want to learn how to use for-loop, but it is difficult to help you because you did not provide a reproducible example. On the other hand, in R a lot of functions were vectorized, meaning that you can avoid for-loop to achieve the same task with more efficient ways.
Based on the description in your post "The goal for the function is to find the indexes whose differences are as close to 30 as possible and save them in z." I provided the following example to address your question without a for-loop.
z <- which.min(abs(diff(vec) - 30))
z
# [1] 49
vec[c(z, z + 1)]
# [1] 627.4461 648.0835
Based on the data you provided, the indices with the numbers difference which are the closest to 30 is 49. The numbers are 627.4461 and 648.0835.
Data
vec <- c("12.01485 26.94091 33.32458 49.46742 65.07425 76.05700 87.11043
100.64116 111.72977 125.72649 139.46460 153.67292 171.46393
184.54244 201.20850 214.05093 224.16196 237.12485 251.51753
258.45865 273.95466 285.42704 299.01869 312.35587 326.26289
339.78724 353.81854 363.15847 378.89307 390.66134 402.22007
412.86049 424.23181 438.50462 448.88005 462.59917 473.65289
487.20678 499.80053 509.14141 526.03873 540.17209 550.69941
565.74602 576.06882 589.07297 598.53208 614.20677 627.44605
648.08346 665.49614 681.46445 691.01806 704.05762 714.09172
732.04124 745.90960 758.52628 769.80519 779.41537 788.35732
805.78547 818.75262 832.71196 844.97859 856.08608 865.72998
875.55945 887.20862 900.00000")
vec <- strsplit(vec, split = " ")[[1]]
vec <- as.numeric(grep("[0-9]+\\.[0-9]+", vec, value = TRUE))

R - numerical errors with analytical gradient?

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
}

Calculate Taylor series using rSymPy

I have been trying out the R interface rSymPy to the CAS SymPy and it works quite well. However, I cannot find the correct syntax for using some of the more complex features, such as finding a Taylor series.
For example, I have tried the following:
library(rSymPy)
sympy("var('p')")
#
##### Cannot make this work ???
#
sympy("from sympy.mpmath import *")
xt <- sympy("p=taylor(exp, 0, 10)")
But it throws the error:
Error in .jcall("RJavaTools", "Ljava/lang/Object;", "invokeMethod", cl, :
SyntaxError: ("no viable alternative at input '='", ('<string>', 1, 8, '__Rsympy= from sympy.mpmath import *\n'))
Any help appreciated.
There does not appear to be an explicit Taylor series available, but the series function is available. The following code works:
library(rSymPy)
sympy("var('p')")
sympy("var('x')") # or sympy("x = Symbol('x', real=True)")
#
xt <- sympy("p=series(exp(x), x, 0, 10)") # expand about 0 to 10th order
which gives the answer:
[1] "1 + x + x**2/2 + x**3/6 + x**4/24 + x**5/120 + x**6/720 + x**7/5040 + x**8/40320 + x**9/362880 + O(x**10)"
We can check this answer by modifying the code to:
library(rSymPy)
sympy("var('p')")
sympy("var('x')") # or sympy("x = Symbol('x', real=True)")
#
xt <- sympy("p=series(exp(x), x, 0, 10)") # expand about 0 to 10th order
# Remove order information
xt0 <- sympy("p.removeO()")
# Test results
x <- 1/3
T1 <- eval(parse(text=xt0)) # Evaluate the result, xt0
T2 <- exp(x) # The correct value
print(T1-T2) # Print the error
Finally, the error from the series expansion is:
[1] -4.811929e-12
I hope this is helpful to anyone else wishing to use the R package rSymPy

Resources