Related
I need to integrate the following function where there is a differentiation term inside. Unfortunately, that term is not easily differentiable.
Is this possible to do something like numerical integration to evaluate this in R?
You can assume 30,50,0.5,1,50,30 for l, tau, a, b, F and P respectively.
UPDATE: What I tried
InnerFunc4 <- function(t,x){digamma(gamma(a*t*(LF-LP)*b)/gamma(a*t))*(x-t)}
InnerIntegral4 <- Vectorize(function(x) { integrate(InnerFunc4, 1, x, x = x)$value})
integrate(InnerIntegral4, 30, 80)$value
It shows the following error:
Error in integrate(InnerFunc4, 1, x, x = x) : non-finite function value
UPDATE2:
InnerFunc4 <- function(t,L){digamma(gamma(a*t*(LF-LP)*b)/gamma(a*t))*(L-t)}
t_lower_bound = 0
t_upper_bound = 30
L_lower_bound = 30
L_upper_bound = 80
step_size = 0.5
integral = 0
t <- t_lower_bound + 0.5*step_size
while (t < t_upper_bound){
L = L_lower_bound + 0.5*step_size
while (L < L_upper_bound){
volume = InnerFunc4(t,L)*step_size**2
integral = integral + volume
L = L + step_size
}
t = t + step_size
}
Since It seems that your problem is only the derivative, you can get rid of it by means of partial integration:
Edit
Not applicable solution for lower integration bound 0.
The renewal function for Weibull distribution m(t) with t = 10 is given as below.
I want to find the value of m(t). I wrote the following r code to compute m(t)
last_term = NULL
gamma_k = NULL
n = 50
for(k in 1:n){
gamma_k[k] = gamma(2*k + 1)/factorial(k)
}
for(j in 1: (n-1)){
prev = gamma_k[n-j]
last_term[j] = gamma(2*j + 1)/factorial(j)*prev
}
final_term = NULL
find_value = function(n){
for(i in 2:n){
final_term[i] = gamma_k[i] - sum(last_term[1:(i-1)])
}
return(final_term)
}
all_k = find_value(n)
af_sum = NULL
m_t = function(t){
for(k in 1:n){
af_sum[k] = (-1)^(k-1) * all_k[k] * t^(2*k)/gamma(2*k + 1)
}
return(sum(na.omit(af_sum)))
}
m_t(20)
The output is m(t) = 2.670408e+93. Does my iteratvie procedure correct? Thanks.
I don't think it will work. First, lets move Γ(2k+1) from denominator of m(t) into Ak. Thus, Ak will behave roughly as 1/k!.
In the nominator of the m(t) terms there is t2k, so roughly speaking you're computing sum with terms
100k/k!
From Stirling formula
k! ~ kk, making terms
(100/k)k
so yes, they will start to decrease and converge to something but after 100th term
Anyway, here is the code, you could try to improve it, but it breaks at k~70
N <- 20
A <- rep(0, N)
# compute A_k/gamma(2k+1) terms
ps <- 0.0 # previous sum
A[1] = 1.0
for(k in 2:N) {
ps <- ps + A[k-1]*gamma(2*(k-1) + 1)/factorial(k-1)
A[k] <- 1.0/factorial(k) - ps/gamma(2*k+1)
}
print(A)
t <- 10.0
t2 <- t*t
r <- 0.0
for(k in 1:N){
r <- r + (-t2)^k*A[k]
}
print(-r)
UPDATE
Ok, I calculated Ak as in your question, got the same answer. I want to estimate terms Ak/Γ(2k+1) from m(t), I believe it will be pretty much dominated by 1/k! term. To do that I made another array k!*Ak/Γ(2k+1), and it should be close to one.
Code
N <- 20
A <- rep(0.0, N)
psum <- function( pA, k ) {
ps <- 0.0
if (k >= 2) {
jmax <- k - 1
for(j in 1:jmax) {
ps <- ps + (gamma(2*j+1)/factorial(j))*pA[k-j]
}
}
ps
}
# compute A_k/gamma(2k+1) terms
A[1] = gamma(3)
for(k in 2:N) {
A[k] <- gamma(2*k+1)/factorial(k) - psum(A, k)
}
print(A)
B <- rep(0.0, N)
for(k in 1:N) {
B[k] <- (A[k]/gamma(2*k+1))*factorial(k)
}
print(B)
shows that
I got the same Ak values as you did.
Bk is indeed very close to 1
It means that term Ak/Γ(2k+1) could be replaced by 1/k! to get quick estimate of what we might get (with replacement)
m(t) ~= - Sum(k=1, k=Infinity) (-1)k (t2)k / k! = 1 - Sum(k=0, k=Infinity) (-t2)k / k!
This is actually well-known sum and it is equal to exp() with negative argument (well, you have to add term for k=0)
m(t) ~= 1 - exp(-t2)
Conclusions
Approximate value is positive. Probably will stay positive after all, Ak/Γ(2k+1) is a bit different from 1/k!.
We're talking about 1 - exp(-100), which is 1-3.72*10-44! And we're trying to compute it precisely summing and subtracting values on the order of 10100 or even higher. Even with MPFR I don't think this is possible.
Another approach is needed
OK, so I ended up going down a pretty different road on this. I have implemented a simple discretization of the integral equation which defines the renewal function:
m(t) = F(t) + integrate (m(t - s)*f(s), s, 0, t)
The integral is approximated with the rectangle rule. Approximating the integral for different values of t gives a system of linear equations. I wrote a function to generate the equations and extract a matrix of coefficients from it. After looking at some examples, I guessed a rule to define the coefficients directly and used that to generate solutions for some examples. In particular I tried shape = 2, t = 10, as in OP's example, with step = 0.1 (so 101 equations).
I found that the result agrees pretty well with an approximate result which I found in a paper (Baxter et al., cited in the code). Since the renewal function is the expected number of events, for large t it is approximately equal to t/mu where mu is the mean time between events; this is a handy way to know if we're anywhere in the neighborhood.
I was working with Maxima (http://maxima.sourceforge.net), which is not efficient for numerical stuff, but which makes it very easy to experiment with different aspects. At this point it would be straightforward to port the final, numerical stuff to another language such as Python.
Thanks to OP for suggesting the problem, and S. Pappadeux for insightful discussions. Here is the plot I got comparing the discretized approximation (red) with the approximation for large t (blue). Trying some examples with different step sizes, I saw that the values tend to increase a little as step size gets smaller, so I think the red line is probably a little low, and the blue line might be more nearly correct.
Here is my Maxima code:
/* discretize weibull renewal function and formulate system of linear equations
* copyright 2020 by Robert Dodier
* I release this work under terms of the GNU General Public License
*
* This is a program for Maxima, a computer algebra system.
* http://maxima.sourceforge.net/
*/
"Definition of the renewal function m(t):" $
renewal_eq: m(t) = F(t) + 'integrate (m(t - s)*f(s), s, 0, t);
"Approximate integral equation with rectangle rule:" $
discretize_renewal (delta_t, k) :=
if equal(k, 0)
then m(0) = F(0)
else m(k*delta_t) = F(k*delta_t)
+ m(k*delta_t)*f(0)*(delta_t / 2)
+ sum (m((k - j)*delta_t)*f(j*delta_t)*delta_t, j, 1, k - 1)
+ m(0)*f(k*delta_t)*(delta_t / 2);
make_eqs (n, delta_t) :=
makelist (discretize_renewal (delta_t, k), k, 0, n);
make_vars (n, delta_t) :=
makelist (m(k*delta_t), k, 0, n);
"Discretized integral equation and variables for n = 4, delta_t = 1/2:" $
make_eqs (4, 1/2);
make_vars (4, 1/2);
make_eqs_vars (n, delta_t) :=
[make_eqs (n, delta_t), make_vars (n, delta_t)];
load (distrib);
subst_pdf_cdf (shape, scale, e) :=
subst ([f = lambda ([x], pdf_weibull (x, shape, scale)), F = lambda ([x], cdf_weibull (x, shape, scale))], e);
matrix_from (eqs, vars) :=
(augcoefmatrix (eqs, vars),
[submatrix (%%, length(%%) + 1), - col (%%, length(%%) + 1)]);
"Subsitute Weibull pdf and cdf for shape = 2 into discretized equation:" $
apply (matrix_from, make_eqs_vars (4, 1/2));
subst_pdf_cdf (2, 1, %);
"Just the right-hand side matrix:" $
rhs_matrix_from (eqs, vars) :=
(map (rhs, eqs),
augcoefmatrix (%%, vars),
[submatrix (%%, length(%%) + 1), col (%%, length(%%) + 1)]);
"Generate the right-hand side matrix, instead of extracting it from equations:" $
generate_rhs_matrix (n, delta_t) :=
[delta_t * genmatrix (lambda ([i, j], if i = 1 and j = 1 then 0
elseif j > i then 0
elseif j = i then f(0)/2
elseif j = 1 then f(delta_t*(i - 1))/2
else f(delta_t*(i - j))), n + 1, n + 1),
transpose (makelist (F(k*delta_t), k, 0, n))];
"Generate numerical right-hand side matrix, skipping over formulas:" $
generate_rhs_matrix_numerical (shape, scale, n, delta_t) :=
block ([f, F, numer: true], local (f, F),
f: lambda ([x], pdf_weibull (x, shape, scale)),
F: lambda ([x], cdf_weibull (x, shape, scale)),
[genmatrix (lambda ([i, j], delta_t * if i = 1 and j = 1 then 0
elseif j > i then 0
elseif j = i then f(0)/2
elseif j = 1 then f(delta_t*(i - 1))/2
else f(delta_t*(i - j))), n + 1, n + 1),
transpose (makelist (F(k*delta_t), k, 0, n))]);
"Solve approximate integral equation (shape = 3, t = 1) via LU decomposition:" $
fpprintprec: 4 $
n: 20 $
t: 1;
[AA, bb]: generate_rhs_matrix_numerical (3, 1, n, t/n);
xx_by_lu: linsolve_by_lu (ident(n + 1) - AA, bb, floatfield);
"Iterative solution of approximate integral equation (shape = 3, t = 1):" $
xx: bb;
for i thru 10 do xx: AA . xx + bb;
xx - (AA.xx + bb);
xx_iterative: xx;
"Should find iterative and LU give same result:" $
xx_diff: xx_iterative - xx_by_lu[1];
sqrt (transpose(xx_diff) . xx_diff);
"Try shape = 2, t = 10:" $
n: 100 $
t: 10 $
[AA, bb]: generate_rhs_matrix_numerical (2, 1, n, t/n);
xx_by_lu: linsolve_by_lu (ident(n + 1) - AA, bb, floatfield);
"Baxter, et al., Eq. 3 (for large values of t) compared to discretization:" $
/* L.A. Baxter, E.M. Scheuer, D.J. McConalogue, W.R. Blischke.
* "On the Tabulation of the Renewal Function,"
* Econometrics, vol. 24, no. 2 (May 1982).
* H(t) is their notation for the renewal function.
*/
H(t) := t/mu + sigma^2/(2*mu^2) - 1/2;
tx_points: makelist ([float (k/n*t), xx_by_lu[1][k, 1]], k, 1, n);
plot2d ([H(u), [discrete, tx_points]], [u, 0, t]), mu = mean_weibull(2, 1), sigma = std_weibull(2, 1);
I am trying to Implement gradient Descent algorithm from scratch to find the slope and intercept value for my linear fit line.
Using the package and calculating slope and intercept, I get slope = 0.04 and intercept = 7.2 but when I use my gradient descent algorithm for the same problem, I get slope and intercept both values = (-infinity,-infinity)
Here is my code
x= [1,2,3,4,5,6,7,8,9,10,11,12,13,141,5,16,17,18,19,20]
y=[2,3,4,5,6,7,8,9,10,11,12,13,141,5,16,17,18,19,20,21]
function GradientDescent()
m=0
c=0
for i=1:10000
for k=1:length(x)
Yp = m*x[k] + c
E = y[k]-Yp #error in predicted value
dm = 2*E*(-x[k]) # partial derivation of cost function w.r.t slope(m)
dc = 2*E*(-1) # partial derivate of cost function w.r.t. Intercept(c)
m = m + (dm * 0.001)
c = c + (dc * 0.001)
end
end
return m,c
end
Values = GradientDescent() # after running values = (-inf,-inf)
I have not done the math, but instead wrote the tests. It seems you got a sign error when assigning m and c.
Also, writing the tests really helps, and Julia makes it simple :)
function GradientDescent(x, y)
m=0.0
c=0.0
for i=1:10000
for k=1:length(x)
Yp = m*x[k] + c
E = y[k]-Yp
dm = 2*E*(-x[k])
dc = 2*E*(-1)
m = m - (dm * 0.001)
c = c - (dc * 0.001)
end
end
return m,c
end
using Base.Test
#testset "gradient descent" begin
#testset "slope $slope" for slope in [0, 1, 2]
#testset "intercept for $intercept" for intercept in [0, 1, 2]
x = 1:20
y = broadcast(x -> slope * x + intercept, x)
computed_slope, computed_intercept = GradientDescent(x, y)
#test slope ≈ computed_slope atol=1e-8
#test intercept ≈ computed_intercept atol=1e-8
end
end
end
I can't get your exact numbers, but this is close. Perhaps it helps?
# 141 ?
datax = [1,2,3,4,5,6,7,8,9,10,11,12,13,141,5,16,17,18,19,20]
datay = [2,3,4,5,6,7,8,9,10,11,12,13,141,5,16,17,18,19,20,21]
function gradientdescent()
m = 0
b = 0
learning_rate = 0.00001
for n in 1:10000
for i in 1:length(datay)
x = datax[i]
y = datay[i]
guess = m * x + b
error = y - guess
dm = 2error * x
dc = 2error
m += dm * learning_rate
b += dc * learning_rate
end
end
return m, b
end
gradientdescent()
(-0.04, 17.35)
It seems that adjusting the learning rate is critical...
Question
What is the equivilant of R code:nleqslv(xstart,f, method="Newton", control=list(allowSingular=TRUE)) in matlab? Particularly, how can something like this control=list(allowSingular=TRUE) in matlab be achieved?
Background
My research is based on research from somebody who is programming in R. I am using matlab. I am trying to transfer his code into matlab. I am stuck, because I cannot solve an equation which is solved like this, nleqslv(xstart,f, method="Newton", control=list(allowSingular=TRUE)) in R. I believe the important part is control=list(allowSingular=TRUE)).
This is an extract of R Code which I modified to make it work without the rest of the code.
if(!require(pracma)){install.packages("pracma")}
if(!require(nleqslv)){install.packages("nleqslv")}
library(pracma)
library(nleqslv)
n = 4
c = 2
m = 10
rest = c(0.4089769, 0.8830174, 0.9404673, 0.0455565, 0.5281055)
alpha = c(-0.751574, -1.763454, 2.515028, 0, 0, 0, 0, 0, 0, 0)
LstarC = rbind(c( -0.751574,0,0,0),
c(-1.763454,0,0,0),
c(2.515028,0,0,0),
c(0,0,0,0),
c(0,0,0,0),
c(0,0,0,0),
c(0,0,0,0),
c(0,0,0,0),
c(0,0,0,0),
c(0,0,0,0))
bstar = rbind(c(1.000000e+00),
c(5.551115e-17),
c(0.000000e+00),
c(0.000000e+00))
fnbeta2 <- function(x, c, rest, alpha, LstarC, n, bstar, m) {
y <- numeric(n+c-1)
y[1] <- sum(x[1:(n+c-1)])+sum(rest)
y[2] <- sum(x[1:(n+c-1)]^2)+sum(rest^2)-m
y[3] <- x[1:(n+c-1)]%*%alpha[1:(n+c-1)]^2-m*bstar[c]+rest%*%alpha[(n+c):m]^2
for(i in seq(from=4,to=4+c-2)){
y[i] <- x[1:(n+c-1)]%*%LstarC[1:(n+c-1),i-3]+rest%*%LstarC[(n+c):m,i-3]
}
return(y)
}
f <- function(x) fnbeta2(x, c, rest, alpha, LstarC, n, bstar, m)
xstart = ones(1,5)
xval2 <- nleqslv(xstart,f, method="Newton", control=list(allowSingular=TRUE))
xval2$x
f(xval2$x)
This is my attempt at transferring the code into matlab.
n = 4;
c = 2;
m = 10;
rest = [0.4089769; 0.8830174; 0.9404673; 0.0455565; 0.5281055];
alpha = [-0.751574; -1.763454; 2.515028; 0; 0; 0; 0; 0; 0; 0];
LstarC = [ -0.751574,0,0,0;
-1.763454,0,0,0; ...
2.515028,0,0,0; ...
0,0,0,0; ...
0,0,0,0; ...
0,0,0,0; ...
0,0,0,0; ...
0,0,0,0; ...
0,0,0,0; ...
0,0,0,0];
bstar = [1.000000e+00; 5.551115e-17; 0.000000e+00; 0.000000e+00];
xstart =ones(n+c-1, 1);
f = #(x) fnbeta( x, c, rest, alpha, LstarC, n, bstar, m );
xval = fsolve(f,xstart)
fnbeta in a seperate .m file
function [ y ] = fnbeta( x, c, rest, alpha, LstarC, n, bstar, m )
y = zeros(n+c-1,1);
y(1) = sum( x( 1:(n+c-1)), 1 ) + sum(rest);
y(2) = sum( x( 1:(n+c-1), 1 ).^2 ) + sum( rest.^2 ) - m;
y(3) = x( 1:(n+c-1), 1 )' * alpha( 1:(n+c-1) ).^2 + ...
rest' * alpha((n+c):m).^2 - m * bstar(c);
for j=4:(4+c-2)
y(j) = x(1:(n+c-1), 1)' * LstarC( 1:(n+c-1), j-3 ) + ...
rest' * LstarC((n+c):m, j-3);
end
end
Matlab traceback
Solver stopped prematurely.
fsolve stopped because it exceeded the function evaluation limit,
options.MaxFunctionEvaluations = 500 (the default value).
I believe my fnbeta or better my anonymous function f is fine because it gives me 0,0,.. when passing in the result R calculates. Furthermore R gives me only good results if control=list(allowSingular=TRUE) is specified:
Update
changing the solver has improved my results, but the deviations are in the region of 10^-3 which I do not find acceptable, because R has gotten so much closer
options = optimoptions('lsqnonlin', 'Algorithm', 'levenberg-marquardt', 'ScaleProblem' ,'jacobian')
xval = lsqnonlin(f,xstart,[],[],options)
I have to simulate some data from a Linear fractional stable motion. I have found an article where they simulate such data using Matlab. The code is from the article "Simulation methods for linear fractional stable motion and
FARIMA using the Fast Fourier Transform" by Stilian Stoev and Murad S. Taqqu. The following is the matlab code:
% Written by Stilian Stoev 05.06.2002, sstoev#math.bu.edu
%
% Usage:
% y = fftlfsn(H,alpha,m,M,C,N,n)
%
mh = 1/m;
d = H-1/alpha;
t0 = [mh:mh:1];
t1 = [1+mh:mh:M];
A = mh^(1/alpha)*[t0.^d, t1.^d-(t1-1).^d];
C = C*(sum(abs(A).^alpha)^(-1/alpha));
A = C*A;
Na = m*(M+N);
A = fft(A,Na);
y = [];
for i=1:n,
if alpha<2,
Z = rstab(alpha,0,Na)’;
elseif alpha==2,
Z = randn(1,Na);
end;
Z = fft(Z,Na);
w = real(ifft(Z.*A,Na));
y = [y; w(1:m:N*m)];
end;
Example:
The commands
H = 0.2; alpha =1.5; m = 256; M = 6000; N = 2^14 - M;
y = fftlfsn(H,alpha,m,M,1,N,1);
x = cumsum(y);
generate a simulated path y of length N of linear
fractional stable noise and a path x of LFSM.
In the following I have tried to translate it,
but I have some questions. I have commented on it in the code.
fftlfsn <- function(H,alpha,m,M,C,N,n){
mh = 1/m;
d = H-1/alpha;
t0 = seq(mh,mh, by =1);
t1 = seq(1+mh,mh, by=M);
# Is the following the right way to translate the matlab code into R?
A = mh^(1/alpha)*matrix(c(t0^d, t1^d-(t1-1)^d), ncol = length(t0), nrow = length(t1));
C = C*(sum(abs(A)^alpha)^(-1/alpha));
A = C*A;
Na = m*(M+N);
# I don't konw if it is right to use the function "fft" here.
#Does this respond directly to the function "fft" in matlab?
A = fft(A,Na);
#how can I do somthing similar in R?
#I think they create an empty matrix? Could I just write y=0?
y = [];
for (i in 1:n)
{
if(alpha<2){
# The function "rstab" generates symmetric alpha-stable variables. Is there a similar function in R, or do you know how to write one?
Z = t(rstab(alpha,0,Na))
}
else if(alpha==2){
Z = matrix (rnorm(Na, mean = 0, sd = 1), nrow = 1, ncol = Na)
}
# Again, can I just use the R-function "fft" directly?
Z = fft(Z,Na);
w = Re(fft(Z*A,Na, inverse= TRUE));
#I have trouble understanding the following and therefore I can't translate it.
y = [y; w(1:m:N*m)];
}
}
Any help appreciated!