Related
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 solving a task for my R online course. The task is to write a function, that solves the quadratic equation with the Lagrange resolvents, or:
x1<--p/2+sqrt((p/2)^2-q)
x2<--p/2-sqrt((p/2)^2-q)
1) If the arguments are non-numeric, the function should return an explained error (or why the error has happend). 2) If there are missing arguments, the function should return an explained error (different from the default). 3) If x1 and x2 are complex numbers (for example if p=-4 and q=7, then x1=2+i*1.73 and x2=2-i*1.73), the function should should also solve the equation instead of generating NaNs and return a warning message, that the numbers are complex. Maybe if I somehow cast it to as.complex, but I want this to be a special case and don't want to cast the basic formula.
My function looks like this:
quadraticEquation<-function(p,q){
if(!is.numeric(c(p,q)))stop("p and q are not numeric") #partly works
if(is.na(c(p,q)))stop("there are argument/s missing") #does not work
x1<--p/2+sqrt((p/2)^2-q)
x2<--p/2-sqrt((p/2)^2-q)
#x1<--p/2+sqrt(as.complex((p/2)^2-q)) works, but I want to perform this only in case the numbers are complex
#x2<--p/2-sqrt(as.complex((p/2)^2-q))
return (c(x1,x2))
}
When testing the function:
quadraticEquation(4,3) #basic case is working
quadraticEquation(TRUE,5) #non-numeric, however the if-statement is not executed, because it assumes that TRUE==1
quadraticEquation(-4,7) #complex number
1) how to write the function, so it assumes TRUE (without "") and anything that is non-numeric as non-numeric?
2) basic case, works.
3) how can I write the function, so it solves the equation and prints the complex numbers and also warns that the numbers are complex (warning())?
Something like this?
quadraticEquation <- function(p, q){
## ------------------------% chek the arguments %---------------------------##
if(
missing(p) | missing(q) # if any of arguments is
){ # missing - stop.
stop("[!] There are argument/s missing")
}
else if(
!is.numeric(p) | !is.numeric(q) | any(is.na(c(p, q))) # !is.numeric(c(1, T))
){ # returns TRUE - conver-
stop("[!] Argument/s p or/and q are not numeric") # tion to the same type
}
## --------------------% main part of the function %--------------------------##
r2 <- p^2 - 4*q # calculate r^2,
if(r2 < 0){ # if r2 < 0 (convert) it
warning("equation has complex roots") # to complex and warn
r2 <- as.complex(r2)
}
# return named roots
setNames(c(-1, 1) * sqrt(r2)/2 - p/2, c("x1", "x2"))
}
quadraticEquation() # No arguments provided
#Error in quadraticEquation() : [!] There are argument/s missing
quadraticEquation(p = 4) # Argument q is missing
#Error in quadraticEquation(p = 4) : [!] There are argument/s missing
quadraticEquation(p = TRUE, q = 7) # p is logical
#Error in quadraticEquation(p = TRUE, q = 7) :
#[!] Argument/s p or/and q are not numeric
quadraticEquation(p = NA, q = 7) # p is NA
#Error in quadraticEquation(p = NA, q = 7) :
#[!] Argument/s p or/and q are not numeric
quadraticEquation(p = 7, q = -4) # real roots
# x1 x2
#-7.5311289 0.5311289
quadraticEquation(p = -4, q = 7) # complex roots
# x1 x2
#2-1.732051i 2+1.732051i
#Warning message:
#In quadraticEquation(p = -4, q = 7) : equation has complex roots
When you write is.numeric(c(p, q)), R first evaluates c(p, q) before determining whether it is numeric or not. In particular if p = TRUE and q = 3, then c(p, q) is promoted to the higher type: c(1, 3).
Here is a vectorized solution, so if p and q are vectors instead of scalars the result is also a vector.
quadraticEquation <- function(p, q) {
if (missing(p)) {
stop("`p` is missing.")
}
if (missing(q)) {
stop("`q` is missing.")
}
if (!is.numeric(p)) {
stop("`p` is not numeric.")
}
if (!is.numeric(q)) {
stop("`q` is not numeric.")
}
if (anyNA(p)) {
stop("`p` contains NAs.")
}
if (anyNA(q)) {
stop("`q` contains NAs.")
}
R <- p^2 / 4 - q
if (min(R) < 0) {
R <- as.complex(R)
warning("Returning complex values.")
}
list(x1 = -p / 2 + sqrt(R),
x2 = -p / 2 - sqrt(R))
}
Also, you should never write x1<--p/2. Keep spaces around infix operators: x1 <- -p/2.
I am trying to compute the MISE of an estimator and for that i need to do the integral of :
(fp(x) - f(x))^2 where f(x) is exp(-x) and fp(x) is : sum_{i}^n { (1/n)*((K((x - X[i])/h))/h) }
The problem here is that X is a matrix, and i don't know how integrate this sum.
I've tried this :
Kgauss <- function(u) dnorm(u) #Gaussian kernel
func = function(x, n, h, X){ ((1/n) * sum(Kgauss((x-X[0:n])/h)/h) - exp(-x))^2 } # h, n are constants
vfunc = Vectorize(func)
integrate(vfunc, n = 3, K = Kgauss, h = 0.25, X = rexp(3), lower = 0, Inf)
But sadly it didn't work out. The big problem here is fp(x), it consists of the sum of multiple functions .
I hope you can help me with this one, I've been struggling for a while now.
Basically i want to make : integral((K(X1) + ... + K(Xn) - exp(-x))²)
You can define the n, h, and K outside the func and then have x as the only parameter:
n = 3; h = 0.25; X = rexp(3)
func = function(x){ ((1/n) * sum(dnorm((x-X[0:n])/h)/h) - exp(-x))^2 }
vfunc = function(x) { sapply(x, func)}
integrate(vfunc, lower = 0, Inf)
# 0.2070893 with absolute error < 1.7e-05
(I'm not sure that you even need to vectorize func. It's built with vectorized functions already.)
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 my main objectif is to obtain the same results on SAS and on R. Somethimes and depending on the case, it is very easy. Otherwise it is difficult, specially when we want to compute something more complicated than the usual.
So, in ored to understand my case, I have the following differential equation system :
y' = z
z' = b* y'+c*y
Let :
b = - 2 , c = - 4, y(0) = 0 and z(0) = 1
In order to resolve this system, in SAS we use the command PROC MODEL :
data t;
do time=0 to 40;
output;
end;
run;
proc model data=t ;
dependent y 0 z 1;
parm b -2 c -4;
dert.y = z;
dert.z = b * dert.y + c * y;
solve y z / dynamic solveprint out=out1;
run;
In R, we could write the following solution using the lsoda function of the deSolve package:
library(deSolve)
b <- -2;
c <- -4;
rigidode <- function(t, y, parms) {
with(as.list(y), {
dert.y <- z
dert.z <- b * dert.y + c * y
list(c(dert.y, dert.z))
})
}
yini <- c(y = 0, z = 1)
times <- seq(from=0,to=40,by=1)
out_ode <- ode (times = times, y = yini, func = rigidode, parms = NULL)
out_lsoda <- lsoda (times = times, y = yini, func = rigidode, parms = NULL)
Here are the results :
SAS
R
For time t=0,..,10 , we obtain similar results. But for t=10,...,40, we start to have differences. For me, these differences are important.
In order to correct these differences, I fixed on R the error truncation term on 1E-9 in stead of 1E-6. I also verified if the numerical integration methods and the hypothesis used by default are the same.
Do you have any idea how to deal with this problem?
Sincerely yours,
Mily