Solving an algebraic equation - r

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

Related

Is there a R function to derive a "kink"

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.

How can I convert a fraction expression into a character vector in R?

Hello an thanks for the help.
I want to convert the expression: x / y (e.g. 1298 / 1109) into a character vector: "x / y" (e.g. "1298 / 1109") using R.
I have tried it with as.character(x/y) and with as.character.Date(x/y) but this only turns the result of the fraction into a character vector.
Do you mean this?
> deparse(quote(1298 / 1109))
[1] "1298/1109"
or
> f <- function(x) deparse(substitute(x))
> f(1298 / 1109)
[1] "1298/1109"
An alternative solution using paste, as mentioned by Allan in the comments, wrapped in a function. Not as flexible as the solution by Tomas, but simple.
f <- function(x,y) {
paste(x, y, sep = " / ")
}
f(1298, 1109)
[1] "1298 / 1109"
As an addition to the excellent answers already given, in case that one wants to be able to evaluate the expression at some point you can take this approach.
x <- 1298
y <- 1109
z <- as.expression(substitute(x / y, list(x = x, y = y)))
z
# expression(1298/1109)
class(z)
# [1] "expression"
eval(z)
# [1] 1.1704
as.character(z)
# [1] "1298/1109"
Or without making it an expression
t <- substitute(x / y, list(x = x, y = y))
t
# 1298/1109 # not a string, but a "call"
class(t)
# [1] "call"
eval(t)
# [1] 1.1704
deparse(t)
# [1] "1298/1109"
With MASS, there is fractions function
MASS::fractions(1298/1109)
[1] 1298/1109

Computing geometric series in R

I would like to compute:
$\sum_{j=1}^n r^j$ for $n=10, 20, 30, 40$, where $r=1.08$
http://quicklatex.com/cache3/76/ql_b64b957d43a0d6a93418cb18eb752576_l3.png
and to see the answers as a vector. I'm working with R; could anyone is able to explain to me how to do this?
So you are playing with power series. You may do:
r <- 1.08 ## this will be a divergent series, toward `Inf`
rr <- r^(1:40)
cumsum(rr)[1:4 * 10]
# [1] 15.64549 49.42292 122.34587 279.78104
The theoretical value is
## define a function
f <- function (n, r) r * (1 - r ^ n) / (1 - r)
## call this function
f(1:4 * 10, 1.08)
# [1] 15.64549 49.42292 122.34587 279.78104
Note, the theoretical result is not (1 - r ^ (n + 1)) / (1 - r), as you start summation from j = 1 instead of j = 0.
The value of r is unstated and I guessing that the formula being requested is not really the correct solution to a compound interest problem, but here is one answer to the question as currently posed:
r = 5.3; for (n in c(10,20,30,40) ) print( sum( r^(1:n) ) )
[1] 21555896
[1] 3.769856e+14
[1] 6.593006e+21
[1] 1.153034e+29
Perhaps (if I interpreted the latex right):
library(purrr)
r <- 1.08
map_dbl(seq(10, 40, 10), function(n) {
sum(r^(1:n))
})
Using only for loop and getting output as a vector:
out=c();
for(i in c(10,20,30,40))
{sum=0;
for(j in 1:i)
{sum=sum+1.08^j};
out=c(out,sum)};
out
Output:
[1] 15.64549 49.42292 122.34587 279.78104
Or:
> out=c();
> for(i in c(10,20,30,40))
+ out=c(out,sum(1.08^(1:i)))
> out
[1] 15.64549 49.42292 122.34587 279.78104
or, in R way:
> sapply(seq(10,40,10), function(x) sum(1.08^(1:x)))
[1] 15.64549 49.42292 122.34587 279.78104

Triple integral in R (how to specifying the domain)

I would like to compute the triple integral of a function of three variables f(x,y,z) in R. I'm using the package cubature and the function adaptIntegrate(). The integrand is equal to 1 only in a certain domain (x<y<z, 0 otherwise) which I don't know how to specify. I'm trying 2 different implementations of the function, but none of them work:
#First implementation
fxyz <- function(w) {
x <- w[1]
y <- w[2]
z <- w[3]
x*y*z*(x < y)&(y < z)
}
#Second implementation
fxyz <- function(w) {
x <- w[1]
y <- w[2]
z <- w[3]
if(x<y&y<z)
out<-1
else
out<-0
out
}
#Computation of integral
library(cubature)
lower <- rep(0,3)
upper <- rep(1, 3)
adaptIntegrate(f=fxyz, lowerLimit=lower, upperLimit=upper, fDim = 3)
Any idea on how to specify the domain correctly?
I don't know about the cubature package, but you can do this by repeated application of base R's integrate function for one-dimensional integration.
f.xyz <- function(x, y, z) ifelse(x < y & y < z, 1, 0)
f.yz <- Vectorize(function(y, z) integrate(f.xyz, 0, 1, y=y, z=z)$value,
vectorize.args="y")
f.z <- Vectorize(function(z) integrate(f.yz, 0, 1, z=z)$value,
vectorize.args="z")
integrate(f.z, 0, 1)
# 0.1666632 with absolute error < 9.7e-05
You'll probably want to play with the control arguments to set the numeric tolerances; small errors in the inner integration can turn into big ones on the outside.
In your first function the return value is wrong. It should be as.numeric(x<=y)*as.numeric(y<=z). In your second function you should also use <= instead of <, otherwise `adapIntegrate won't work correctly. You also need to specify a maximum number of evaluations. Try this
library(cubature)
lower <- rep(0,3)
upper <- rep(1,3)
# First implementation (modified)
fxyz <- function(w) {
x <- w[1]
y <- w[2]
z <- w[3]
as.numeric(x <= y)*as.numeric(y <= z)
}
adaptIntegrate(f=fxyz,lowerLimit=lower,upperLimit=upper,doChecking=TRUE,
maxEval=2000000,absError=10e-5,tol=1e-5)
#$integral
#[1] 0.1664146
#$error
#[1] 0.0001851699
#$functionEvaluations
#[1] 2000031
#$returnCode
#[1] 0
The domain 0 <= x <= y <= z <= 1 is the "canonical" simplex. To integrate over a simplex, use the SimplicialCubature package.
library(SimplicialCubature)
f <- function(x) 1
S <- CanonicalSimplex(3)
> adaptIntegrateSimplex(function(x) 1, S)
$integral
[1] 0.1666667
$estAbsError
[1] 1.666667e-13
$functionEvaluations
[1] 55
$returnCode
[1] 0
$message
[1] "OK"
Note that integrating the constant function f(x)=1 over the simplex simply gives the volume of the simplex, which is 1/6. The integration is useless for this example.
> SimplexVolume(S)
[1] 0.1666667

Taylor approximation in R

Is there a function/package in R which takes a function f and a parameter k, and then returns a Taylor approximation of f of degree k?
You can use Ryacas to work with the yacas computer algebra system (which you will need to install as well)
Using an example from the vignette
library(Ryacas)
# run yacasInstall() if prompted to install yacas
#
yacas("texp := Taylor(x,0,3) Exp(x)")
## expression(x + x^2/2 + x^3/6 + 1)
# or
Now, if you want to turn that into a function that you can give values of x
myTaylor <- function(f, k, var,...){
.call <- sprintf('texp := Taylor( %s, 0, %s) %s', var,k,f)
result <- yacas(.call)
foo <- function(..., print = FALSE){
if(print){print(result)}
Eval(result, list(...))}
return(foo)
}
# create the function
foo <- myTaylor('Exp(x)', 3, 'x')
foo(x=1:5)
## [1] 2.666667 6.333333 13.000000 23.666667 39.333333
foo(x=1:5, print = TRUE)
## expression(x + x^2/2 + x^3/6 + 1)
## [1] 2.666667 6.333333 13.000000 23.666667 39.333333
Compare the above symbolic solution with a numerical Taylor approximation:
library(pracma)
p <- taylor(f = exp, x0 = 0, n = 4) # Numerical coefficients
# 0.1666667 0.5000000 1.0000000 1.0000000 # x^3/6 + x^2/2 + x + 1
polyval(p, 1:5) # Evaluate the polynomial
# 2.66667 6.33333 13.00000 23.66667 39.33334 # exp(x) at x = 1:5
As a followup, consider:
foo <- myTaylor('Exp(x)', 3, 'x')
sprintf('%2.15f',foo(x=1:5))
[1] "2.666666666666667" "6.333333333333333" "13.000000000000000"
[4] "23.666666666666664" "39.333333333333329"
p <- taylor(f = exp, x0 = 0, n = 3)
sprintf('%2.15f',polyval(p,1:5))
[1] "2.666666721845557" "6.333333789579300" "13.000001556539996"
[4] "23.666670376066413" "39.333340601497312"
Which of these is more accurate I'll leave up to the reader :-)
The below function returns the function obtained by using the Taylor series approximation of n-th order of function f at the point a.
taylor <- function(f, n, a) {
ith_derivative <- as.expression(body(f))
f_temp <- function(x) x
series <- as.character(f(a))
for (i in seq_len(n)) {
ith_derivative <- body(f_temp) <- D(ith_derivative, "x")
series <- paste0(series, "+", f_temp(a) / factorial(i), "*(x - ", a, ")^", i)
}
f_output <- function(x) x
body(f_output) <- parse(text = series)
f_output
}
taylor(f = function(x) sin(x), n = 3, a = 0)
If you are asking for Taylor approximation in a background of error propagation, you might try the "propagate" function of my qpcR package, which evaluates symbolic gradient vectors together with the covariance matrix in the form of g * V * t(g) (the famous matrix notation for error propagation), which is equivalent to the first-order Taylor expansion.

Resources