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
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'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 have the following code where I want to find the beste Values for x,y and z.
df <- data.frame(replicate(3,sample(0:100,100,rep=TRUE)))
find_best <- function(xyz) {
x <- xyz[1]
y <- xyz[2]
z <- xyz[3]
nr <- count(df)
val <- count(df[df[, "X1"] < x & df[, "X2"] < y & df[, "X3"] < z, ] )
return(val$n/nr$n)
}
optim(par = c(30,15,15), fn = find_best, lower=c(0,0,0), upper=c(100,100,100), method="L-BFGS-B")
The function does not achieve much at the moment, but I will add constraints later. However if I run this, I only get the value of the initial values back.
$par
[1] 30 15 15
So the question is, how can I get the best values for x,y,z either with optim or with anything else.
Here is an example of how you can use optim for your purpose
set.seed(1)
df <- data.frame(replicate(3,sample(0:100,1e5,rep=TRUE)))
find_best <- function(xyz) {
x <- xyz[1]
y <- xyz[2]
z <- xyz[3]
r <- nrow(subset(df,X1 < x & X2 < y & X3 < z))/nrow(df)
}
res <- optim(par = c(35,15,15), fn = find_best, lower=c(0,0,0), upper=c(100,100,100), control = list(fnscale = -1))
which gives
> res
$par
[1] 35.085 15.205 15.225
$value
[1] 0.00881
$counts
function gradient
2 2
$convergence
[1] 0
$message
[1] "CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL"
I have a vector which is a cumulative distribution function, let say in form
y=seq(0, 1.0, 0.05)
Now I need a function that will get inverse cdf of y, so that
f(0.1)=3
and
f(0.9)=19
Any ideas how to do this?
The which function does this.
> y <- seq(0, 1.0, 0.05)
> which(y == .1)
[1] 3
> which(y == .9)
[1] 19
However, if you are trying to find the inverse cdf, you might have to deal with two vectors x and y, since it is possible that x does take only indices as values. So you might want to do this.
> y <- seq(0, 1.0, 0.05)
> x <- 1:21
> x[which(y == .1)]
[1] 3
> x[which(y == .9)]
[1] 19
I want to create a function which finds components of a vector which increase continually by k-times.
That is, if the contrived function is f(x,k) and x=c(2,3,4,3,5,6,5,7), then
the value of f(x,1) is 2,3,3,5,5 since only these components of x increase by 1 time.
In addition, if k=2, then the value of f(x,2) is 2,3 since only these components increase continually by 2 times.(2→3→4 and 3→5→6)
I guess that I ought to use repetitive syntax like for for this purpose.
1) Use rollapply from the zoo package:
library(zoo)
f <- function(x, k)
x[rollapply(x, k+1, function(x) all(diff(x) > 0), align = "left", fill = FALSE)]
Now test out f:
x <- c(2,3,4,3,5,6,5,7)
f(x, 1)
## [1] 2 3 3 5 5
f(x, 2)
## [1] 2 3
f(x, 3)
## numeric(0)
1a) This variation is slightly shorter and also works:
f2 <- function(x, k) head(x, -k)[ rollapply(diff(x) > 0, k, all) ]
2) Here is a version of 1a that uses no packages:
f3 <- function(x, k) head(x, -k)[ apply(embed(diff(x) > 0, k), 1, all) ]
A fully vectorized solution:
f <- function(x, k = 1) {
rlecumsum = function(x)
{ #cumsum with resetting
#http://stackoverflow.com/a/32524260/1412059
cs = cumsum(x)
cs - cummax((x == 0) * cs)
}
x[rev(rlecumsum(rev(c(diff(x) > 0, FALSE) ))) >= k]
}
f(x, 1)
#[1] 2 3 3 5 5
f(x, 2)
#[1] 2 3
f(x, 3)
#numeric(0)
I don't quite understand the second part of your question (that with k=2) but for the first part you can use something like this:
test<-c(2,3,4,3,5,6,5,7) #Your vector
diff(test) #Differentiates the vector
diff(test)>0 #Turns the vector in a logical vector with criterion >0
test[diff(test)>0] #Returns only the elements of test that correspond to a TRUE value in the previous line