Solving numerically unstable integration in R - r

I have a function which I would like to integrate for x between -Inf and Inf. I'm using the function integrate in R. However, I do get an error saying Non-finite function value.
test_func<-function(x,t,A,sigma, y){
n1 = exp(-((y - x)^2)/(4 * sigma * t)) + exp(-((y + x)^2)/(4 * sigma * t))
d1 = sqrt(4 * pi * sigma * t)
a2 = 2 * A /(sigma) * exp((4 * A *(y + x +(4 * A * t)))/(sigma))
b2 = pracma::erfc(((y + x)+(8 * A * t))/(2 * sqrt(sigma * t)))
res = (n1/d1) - (a2 * b2)
return(res)
}
t<-1000
A<-0.01
sigma<-1
y<-1
integrate(test_func,lower = -Inf , upper = Inf, t,A,sigma,y)$value
And I do get the following error:
Error in integrate(test_func, lower = -Inf, upper = Inf, t, A, sigma, :
non-finite function value
I know that there ways to make such type of integration numerically stable, but I have no idea, which one could help in this case.

Related

MathOptInterface.OTHER_ERROR when trying to use ISRES of NLopt through JuMP

I am trying to minimize a nonlinear function with nonlinear inequality constraints with NLopt and JuMP.
In my test code below, I am minimizing a function with a known global minima.
Local optimizers such as LD_MMA fails to find this global minima, so I am trying to use global optimizers of NLopt that allow nonlinear inequality constraintes.
However, when I check my termination status, it says “termination_status(model) = MathOptInterface.OTHER_ERROR”. I am not sure which part of my code to check for this error.
What could be the cause?
I am using JuMP since in the future I plan to use other solvers such as KNITRO as well, but should I rather use the NLopt syntax?
Below is my code:
# THIS IS A CODE TO SOLVE FOR THE TOYMODEL
# THE EQUILIBRIUM IS CHARACTERIZED BY A NONLINEAR SYSTEM OF ODEs OF INCREASING FUCTIONS B(x) and S(y)
# THE GOAL IS TO APPROXIMATE B(x) and S(y) WITH POLYNOMIALS
# FIND THE POLYNOMIAL COEFFICIENTS THAT MINIMIZE THE LEAST SQUARES OF THE EQUILIBRIUM EQUATIONS
# load packages
using Roots, NLopt, JuMP
# model primitives and other parameters
k = .5 # equal split
d = 1 # degree of polynomial
nparam = 2*d+2 # number of parameters to estimate
m = 10 # number of grids
m -= 1
vGrid = range(0,1,m) # discretize values
c1 = 0 # lower bound for B'() and S'()
c2 = 2 # lower and upper bounds for offers
c3 = 1 # lower and upper bounds for the parameters to be estimated
# objective function to be minimized
function obj(α::T...) where {T<:Real}
# split parameters
αb = α[1:d+1] # coefficients for B(x)
αs = α[d+2:end] # coefficients for S(y)
# define B(x), B'(x), S(y), and S'(y)
B(v) = sum([αb[i] * v .^ (i-1) for i in 1:d+1])
B1(v) = sum([αb[i] * (i-1) * v ^ (i-2) for i in 2:d+1])
S(v) = sum([αs[i] * v .^ (i-1) for i in 1:d+1])
S1(v) = sum([αs[i] * (i-1) * v ^ (i-2) for i in 2:d+1])
# the equilibrium is characterized by the following first order conditions
#FOCb(y) = B(k * y * S1(y) + S(y)) - S(y)
#FOCs(x) = S(- (1-k) * (1-x) * B1(x) + B(x)) - B(x)
function FOCb(y)
sy = S(y)
binv = find_zero(q -> B(q) - sy, (-c2, c2))
return k * y * S1(y) + sy - binv
end
function FOCs(x)
bx = B(x)
sinv = find_zero(q -> S(q) - bx, (-c2, c2))
return (1-k) * (1-x) * B1(x) - B(x) + sinv
end
# evaluate the FOCs at each grid point and return the sum of squares
Eb = [FOCb(y) for y in vGrid]
Es = [FOCs(x) for x in vGrid]
E = [Eb; Es]
return E' * E
end
# this is the actual global minimum
αa = [1/12, 2/3, 1/4, 2/3]
obj(αa...)
# do optimization
model = Model(NLopt.Optimizer)
set_optimizer_attribute(model, "algorithm", :GN_ISRES)
#variable(model, -c3 <= α[1:nparam] <= c3)
#NLconstraint(model, [j = 1:m], sum(α[i] * (i-1) * vGrid[j] ^ (i-2) for i in 2:d+1) >= c1) # B should be increasing
#NLconstraint(model, [j = 1:m], sum(α[d+1+i] * (i-1) * vGrid[j] ^ (i-2) for i in 2:d+1) >= c1) # S should be increasing
register(model, :obj, nparam, obj, autodiff=true)
#NLobjective(model, Min, obj(α...))
println("")
println("Initial values:")
for i in 1:nparam
set_start_value(α[i], αa[i]+rand()*.1)
println(start_value(α[i]))
end
JuMP.optimize!(model)
println("")
#show termination_status(model)
#show objective_value(model)
println("")
println("Solution:")
sol = [value(α[i]) for i in 1:nparam]
My output:
Initial values:
0.11233072522513032
0.7631843020124309
0.3331559403539963
0.7161240026812674
termination_status(model) = MathOptInterface.OTHER_ERROR
objective_value(model) = 0.19116585196576466
Solution:
4-element Vector{Float64}:
0.11233072522513032
0.7631843020124309
0.3331559403539963
0.7161240026812674
I answered on the Julia forum: https://discourse.julialang.org/t/mathoptinterface-other-error-when-trying-to-use-isres-of-nlopt-through-jump/87420/2.
Posting my answer for posterity:
You have multiple issues:
range(0,1,m) should be range(0,1; length = m) (how did this work otherwise?) This is true for Julia 1.6. The range(start, stop, length) method was added for Julia v1.8
Sometimes your objective function errors because the root doesn't exist. If I run with Ipopt, I get
ERROR: ArgumentError: The interval [a,b] is not a bracketing interval.
You need f(a) and f(b) to have different signs (f(a) * f(b) < 0).
Consider a different bracket or try fzero(f, c) with an initial guess c.
Here's what I would do:
using JuMP
import Ipopt
import Roots
function main()
k, d, c1, c2, c3, m = 0.5, 1, 0, 2, 1, 10
nparam = 2 * d + 2
m -= 1
vGrid = range(0, 1; length = m)
function obj(α::T...) where {T<:Real}
αb, αs = α[1:d+1], α[d+2:end]
B(v) = sum(αb[i] * v^(i-1) for i in 1:d+1)
B1(v) = sum(αb[i] * (i-1) * v^(i-2) for i in 2:d+1)
S(v) = sum(αs[i] * v^(i-1) for i in 1:d+1)
S1(v) = sum(αs[i] * (i-1) * v^(i-2) for i in 2:d+1)
function FOCb(y)
sy = S(y)
binv = Roots.fzero(q -> B(q) - sy, zero(T))
return k * y * S1(y) + sy - binv
end
function FOCs(x)
bx = B(x)
sinv = Roots.fzero(q -> S(q) - bx, zero(T))
return (1-k) * (1-x) * B1(x) - B(x) + sinv
end
return sum(FOCb(x)^2 + FOCs(x)^2 for x in vGrid)
end
αa = [1/12, 2/3, 1/4, 2/3]
model = Model(Ipopt.Optimizer)
#variable(model, -c3 <= α[i=1:nparam] <= c3, start = αa[i]+ 0.1 * rand())
#constraints(model, begin
[j = 1:m], sum(α[i] * (i-1) * vGrid[j]^(i-2) for i in 2:d+1) >= c1
[j = 1:m], sum(α[d+1+i] * (i-1) * vGrid[j]^(i-2) for i in 2:d+1) >= c1
end)
register(model, :obj, nparam, obj; autodiff = true)
#NLobjective(model, Min, obj(α...))
optimize!(model)
print(solution_summary(model))
return value.(α)
end
main()

How to compute this double integral in r?

I'm wanting to compute an integral of the following density function :
Using the packages "rmutil" and "psych" in R , i tried :
X=c(8,1,2,3)
Y=c(5,2,4,6)
correlation=cov(X,Y)/(SD(X)*SD(Y))
bvtnorm <- function(x, y, mu_x = mean(X), mu_y = mean(Y), sigma_x = SD(X), sigma_y = SD(Y), rho = correlation) {
force(x)
force(y)
function(x, y)
1 / (2 * pi * sigma_x * sigma_y * sqrt(1 - rho ^ 2)) *
exp(- 1 / (2 * (1 - rho ^ 2)) * ((x - mu_x) / sigma_x) ^ 2 +
((y - mu_y) / sigma_y) ^ 2 - 2 * rho * (x - mu_x) * (y - mu_y) /
(sigma_x * sigma_y))
}
f2 <- bvtnorm(x, y)
print("sum_double_integral :")
integral_1=int2(f2, a=c(-Inf,-Inf), b=c(Inf,Inf)) # should normaly give 1
print(integral_1) # gives Nan
The problem :
This integral should give 1 , but it gives Nan ??
I don't know how can i fix the problem , i tried to force() x and y variables without success.
You were missing a pair of parentheses. The corrected code looks like:
library(rmutil)
X=c(8,1,2,3)
Y=c(5,2,4,6)
correlation=cor(X,Y)
bvtnorm <- function(x, y, mu_x = mean(X), mu_y = mean(Y), sigma_x = sd(X), sigma_y = sd(Y), rho = correlation) {
function(x, y)
1 / (2 * pi * sigma_x * sigma_y * sqrt(1 - rho ^ 2)) *
exp(- 1 / (2 * (1 - rho ^ 2)) * (((x - mu_x) / sigma_x) ^ 2 +
((y - mu_y) / sigma_y) ^ 2 - 2 * rho * (x - mu_x) * (y - mu_y) /
(sigma_x * sigma_y)))
}
f2 <- bvtnorm(x, y)
print("sum_double_integral :")
integral_1=int2(f2, a=c(-Inf,-Inf), b=c(Inf,Inf)) # should normaly give 1
print(integral_1) # prints 1.000047
This was hard to spot. From a debugging point of view, I found it helpful to first integrate over a finite domain. Trying it with things like first [-1,1] and then [-2,2] (on both axes) showed that the integrals were blowing up rather than converging. After that, I looked at the grouping even more carefully.
I also cleaned up the code a bit. I dropped SD in favor of sd since I don't see the motivation in importing the package psych just to make the code less readable (less flippantly, dropping psych from the question makes it easier for others to reproduce. There is no good reason to include a package which isn't be used in any essential way). I also dropped the force() which was doing nothing and used the built-in function cor for calculating the correlation.

Calculating double integral with gamma incomplete function in R

I need to calculate a double integral on two variables (B0 and B1) in R.
Till now, nothing complicated with the int2 function.
But, my function to integrate includes gamma incomplete function (gammainc in R ) !
The following error message appears :
Error in gammainc(1/eta, lambda * exp(B0 + B1 * z_arm) * tmax^eta) :
Arguments must be of length 1; function is not vectorized.
Any advice to help me ?
tmax = 5
Sig = matrix ( c(0.2, 0, 0, 0.4) , ncol = 2 )
Mu = matrix ( c(1, 0) , ncol = 1 )
eta = 0.5
lambda = 0.8
z_arm = c(rep(0.5,10), rep(1,15))
to.integrate = function(B0, B1)
{
first.int = 1/eta *(lambda * exp(B0 + B1 * z_arm))^(-1/eta)* gammainc(1/eta, lambda * exp(B0 + B1 * z_arm)*tmax^eta)['lowinc']
B = matrix(c(B0, B1), ncol=1)
multi.norm = 1 / (2 * pi * det(Sig)^(1/2)) * exp (- 0.5 * t( B - Mu ) * solve(Sig) * ( B - Mu ) )
return (first.int * multi.norm)
}
int2(to.integrate , a=c(-Inf,-Inf), b=c(Inf,Inf), eps=1.0e-6, max=16, d=5)
Thanks for any help!

Non Linear Optimization in R with nloptr vs Excel

I can't seem to find an answer for my particular problem. I'm trying to minimize the mean absolute error between a real value vector and a linear combination of models as follows:
library(nloptr)
df <- data.frame(
real = c(24.2418, 21.7374, 7.203, 115.0233, 16.632, 5.4644, 27.8917, 0.5904, 0.633, 105.3656, 110.0564, 122.9399, 23.0418, 4.2186, 109.5453),
m_1 = c(17.7790979854662, 32.93639375, 6.94294375000066, 98.909065625, 80.1068562499999, 11.656556250002, 39.868921875, 0.859157480988586, 0.612625482376216, 112.580383416359, 151.896765176957, 155.81521460987, 7.3257, 4.1268, 41.5711703205879),
m_2 = c(25.5062900474607, 32.7709877317137, 6.94317649489279, 98.898593448344, 80.1114267521597, 11.6563450007055, 39.8691722409057, 0.907260912997819, 0.602795676399197, 114.183526809465, 139.51052151724, 149.993624420536, 6.85002142907728, 4.66668862149305, 70.7527906311631),
m_3 = c(27.1495912199999, 40.2339353399999, 7.10339542, 87.1444967133334, 58.4563384933332, 11.1378198366666, 37.6030141333333, 0.852288459999999, 0.681724560000002, 100.101136186666, 118.536525109999, 136.923264319999, 5.64763034333333, 4.8659515, 70.12675835),
m_4 = c(25.511590625, 32.9363937499999, 7.00050769504031, 98.3660974929738, 80.10685625, 11.65655625, 39.868921875, 0.665580984791989, 0.498756215272925, 85.791042265746, 135.619508469251, 140.946144588455, 5.05824305930683, 3.25333636845094, 22.0908752674237),
m_5 = c(25.6118152340655, 34.5646719234769, 6.82416840383483, 91.5582383465651, 84.4603847826215, 11.3405620277701, 40.7906062254877, 0.908706704665592, 0.602817399156822, 114.326905157898, 139.595783699511, 150.046375909198, 6.8511793011574, 4.6622942290559, 56.2753212961812),
m_6 = c(21.9868574376585, 44.3147731773466, 6.38315486686481, 100.303757097094, 9.13921010739697, 7.83817900918309, 31.5458855316741, 1.09960505333834, 0.817751834425678, 101.110814846224, 145.55847538105, 142.82362305075, 7.61732986965459, 4.6774198307473, 67.5821464371521)
)
best_dist <- function(x) {
output <- df$m_1 * x[1] + df$m_2 * x[2] + df$m_3 * x[3] +
df$m_4 * x[4] + df$m_5 * x[5] + df$m_6 * x[6]
mean(abs(output - df$real))
}
restriction <- function(x) sum(x) - 1
nloptr(
x0 = rep(1 / 6, 6),
eval_f = best_dist,
lb = rep(0, 6),
ub = rep(1, 6),
eval_g_eq = restriction,
opts = list(algorithm = "NLOPT_GN_ISRES", xtol_rel = 1e-16, maxeval = 1e4)
)
As you could read I'm using the nloptr package. The above code yields the not optimal result of 14.85 for the objective function and the parameters are all the inital parameters. You may change the initial parameters to some other vector and still won't get the optimal solution.
However, using the excel solver one can easily get a result of 10.77 for the objective function and (0, 0, .15, 0, 0, .85) for the parameters.
I've tried using an algorithm with gradient, however I can't seem to get the syntax right. Here's my other attempt.
gradient <- function(x) {
output <- df$m_1 * x[1] + df$m_2 * x[2] + df$m_3 * x[3] +
df$m_4 * x[4] + df$m_5 * x[5] + df$m_6 * x[6]
err <- output - df$real
c(
- sum(sign(err) * df$m_1),
- sum(sign(err) * df$m_2),
- sum(sign(err) * df$m_3),
- sum(sign(err) * df$m_4),
- sum(sign(err) * df$m_5),
- sum(sign(err) * df$m_6)
)
}
nloptr(
x0 = runif(6),
eval_f = best_dist,
eval_grad_f = gradient,
lb = rep(0, 6),
ub = rep(1, 6),
eval_g_eq = restriction,
opts = list(algorithm = "NLOPT_GN_ISRES", xtol_rel = 1e-16, maxeval = 1e4)
)
This is like LAD Regression with a side constraint. LP (linear programming) formulations for LAD regression are shown here. Using your naming of the data (real[i], m[i,j]), we have:
min sum(i, | real[i] - sum(j,m[i,j]*x[j]) | )
subject to
sum(j, x[j]) = 1
0 <= x[j] <= 1
This can be linearized (using variable splitting) as follows:
min sum(i, r1[i]+r2[i])
subject to
r1[i]-r2[i] = real[i] - sum(j,m[i,j]*x[j])
sum(j, x[j]) = 1
bounds:
r1[i], r2[i] >= 0 (positive variables)
0 <= x[j] <= 1
This is a pure LP and can be solved with any LP solver.

Using lanczos low pass filter in R program

I am wondering if there is any package which allows us to use the Lanczos filter. I found other filters such as butterworth but I am looking for Lanczos low pass filter.
How different is Lanczos filter from butterworth filter ? Any suggestions or hints is appreciated.
Thanks.
Using the web I find this MATLAB implementation.
If you skipped the first part(arguments check), it looks simple to write its R equivalent.
# Cf - Cut-off frequency (default: half Nyquist)
# M - Number of coefficients (default: 100)
lanczos_filter_coef <- function(Cf,M=100){
lowpass_cosine_filter_coef <- function(Cf,M)
coef <- Cf*c(1,sin(pi*seq(M)*Cf)/(pi*seq(M)*Cf))
hkcs <- lowpass_cosine_filter_coef(Cf,M)
sigma <- c(1,sin(pi*seq(M)/M)/(pi*seq(M)/M))
hkB <- hkcs*sigma
hkA <- -hkB
hkA[1] <- hkA[1]+1
coef <- cbind(hkB, hkA)
coef
}
To test it for example:
dT <- 1
Nf <- 1/(2*dT)
Cf <- Nf/2
Cf <- Cf/Nf
lanczos_filter_coef(Cf,5)
hkB hkA
[1,] 5.000000e-01 5.000000e-01
[2,] 2.977755e-01 -2.977755e-01
[3,] 1.475072e-17 -1.475072e-17
[4,] -5.353454e-02 5.353454e-02
[5,] -4.558222e-18 4.558222e-18
[6,] 2.481571e-18 -2.481571e-18
PS I don't know very well MATLAB(used it many years ago), so I I used this link For the R/MATLAB analogy. I hope that someone with more R/MATLAB/Scilab knowledge can test my code.
I used the method provided in this link https://www.atmos.umd.edu/~ekalnay/syllabi/AOSC630/METO630ClassNotes13.pdf and wrote this function:
`
lanczos_weights<-function(window=101,sampl_rate=1,type="lowpass",low_freq=1/100,high_freq=1/10){
low_freq=sampl_rate*low_freq
high_freq=sampl_rate*high_freq
if (type=="lowpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=low_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w=w[-c(1,length(w))]}
else if (type=="highpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=high_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w=w[-c(1,length(w))]
w=-w
w[order]=1-2*fc }
else if (type=="bandpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=low_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w1=w[-c(1,length(w))]
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=high_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w2=w[-c(1,length(w))]
w=w2-w1}
else {print("Please specify a valid filter type: either 'lowpass', 'highpass' or 'bandpass'")}
return(w)}
`
#### the inputs are:
#### window: Filter length=number of weights. Corresponds to the total number of points to be lost. Should be odd: window=2N-1. The formula for N is taken from Poan et al. (2013)
#### sampl_rate: sampling rate=number of observation per time unit. ( eg: if time unit is one day, hourly data have sampl_rate=1/24)
#### type= one of "lowpass", "highpass" and "bandpass"
#### low_freq: the lowest frequency
#### high_freq: the highest frequency
I have compared my weights to those obtained using NCL filwgts_lanczos and they are exactly the same.

Resources