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);
Summary of problem
My objective is to create a function called newton.raphson to implement the Newton-Raphson root-finding algorithm.
Root Finding Algorithm: x1 = X0 - f(xo)/f'(x0)
I have 2 arguments:
iter = number of iteration (value = 10^5)
epsilon = for the tolerance (value = 10^-10)
Can not depend on variables outside of the function
newton.raphson <- function(f, x0, iter=1e5, epsilon=1e-10) {
x <- x0
h <- 1e-5
for (t in 1:iter) {
drvt <- f((x+h)) - f((x-h)) / (2 * h)
update <- x - f(x)/ drvt
if (abs(update) < epsilon) {
break
}
x <- update
}
root <- x
return(root)
}
# Define some function to test
f <- function(x) {
x^2 - 4 * x - 7
}
I get the following results:
> newton.raphson(f, 0)
[1] 2.000045
> newton.raphson(f, 3)
[1] 5.000024
But results should be:
-1.316625
5.316625
Your derivative calculation is a little bit broken - you forgot parenthesis around the difference between f(x+h) and f(x-h):
drvt <- ( f(x+h) - f(x-h) ) / (2 * h)
Also, you should compare the difference between the old and new root approximation to the tolerance. In order to make things more clear, rename your misleading update variable to something like new.x. Then, your should check if (abs(new.x - x) < epsilon).
fellow programmers. I'm studying a book on numerical solutions for economics (Judd 1998). I'm trying to reproduce a problem from that same book in R so I can use the optim package to see if I can get similar results.
The problem established by the author is this one: and his results were these.
I have tried to transcribe this problem to R, which resulted in this code chunk:
DisutilityJudd <- function(L){
if(L == 0){
return(0)
}else{
return(0.1)
}
}
AgentUtilityJudd <- function(w, L){
(-exp(-2*w) + 1) - DisutilityJudd(L)
}
reservation.utility.judd <- AgentUtilityJudd(1, 1)
MaxEffortUtility <- function(w1, w2, L = 1){
0.8 * AgentUtilityJudd(w1, L) + 0.2 * AgentUtilityJudd(w2, L)
}
LeastEffortUtility <- function(w1, w2, L = 0){
0.4 * AgentUtilityJudd(w1, L) + 0.6 * AgentUtilityJudd(w2, L)
}
UtilityDifferenceJudd <- function(w1, w2){
MaxEffortUtility(w1, w2) - LeastEffortUtility(w1, w2)
}
PenaltyFunctionJudd <- function(w1, w2, P = 100000){
if(length(w1) == 2){
y <- -1 * (0.8 * (2 - w1[1]) - 0.2 * w1[2] - P *
(pmax(0, -MaxEffortUtility(w1[1], w1[1]) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1[1], w1[1])))^2)
}else{
y <- -1 * (0.8 * (2 - w1) - 0.2 * w2 - P *
(pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1, w2)))^2)
}
return(y)
}
There were no errors, but the results generated by my code were nowhere near to what I was expecting:
optim(c(1.1, 0.5), PenaltyFunctionJudd)
$par
[1] 1.343909e+49 -2.370681e+51
$value
[1] -4.633849e+50
$counts
function gradient
501 NA
$convergence
[1] 1
$message
NULL
Perhaps there is a problem to my penalty function. I'm assuming that it is due to the pmax function. Could somebody help me identify it? Thank you, I appreciate your attention.
Edit: a typo.
I believe you meant w1[2] in when if(length(w1) == 2) is true.
I have modified your code, without touching how you define the previous function. It is not clear if it the result expected : what does IV(-1) mean, is it the result minus 1 ? a power if 10 ?
PenaltyFunctionJudd <- function(w1, w2, P = 1e5){
if(length(w1) > 1){
w2 <- w1[2]
w1 <- w1[1]
}
# cat("length is 2 \n")
y <- 0.8 * (2 - w1) - 0.2 * w2 - P *
( pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd) )^2 -
P * ( pmax(0, -UtilityDifferenceJudd(w1, w2)) )^2
# cat("pmax1 :", pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd), "\n")
# cat("pmax2 :", pmax(0, -UtilityDifferenceJudd(w1, w2)), "\n")
return(y)
}
optim(c(1.1, 0.5), PenaltyFunctionJudd, control = list(fnscale = -1) )
optim(c(11, 5), PenaltyFunctionJudd, method = "BFGS", control = list(fnscale = -1, maxit = 100) )
You can use cat or print to check your values (here I noticed some Inf and 0 the leaded me to notice code error).
Friendly warning : provided you defined correctly the previous function, there is lot of instability in optimisation (problem badly set ? More penalty needed ?). Indeed when running twice or more the algorithm parameters fluctuate a lot...
The integrate() function returns the integrated value, but what if the user wants to take the integrated equation for an interval?
For example, the normal case of integrate() is like below:
integrate(f = function(x){2 * x}, lower = 1, upper = 2)
>3 with absolute error < 3.3e-14
But I want to write something like this:
integrate(f = function(x){2 * x}, lower = t, upper = t + 1)
to get
2 * t + 1
Thanks
The Ryacas package does symbolic computation:
install.packages("Ryacas")
library(Ryacas)
help(pac=Ryacas)
yacas("Integrate(x,t,t+1)2*x")
# expression((t + 1)^2 - t^2)
Simplify("%") # apply simplification to last result
# expression(2 * t + 1)
I have a small MATLAB script mainly doing derivatives using symbolic toolbox that I want to rewrite into R. I chose Ryacas package because I found rSymPy too tricky to install... Here is my R code
# install.packages('Ryacas')
library(Ryacas)
z <- Sym("z")
psi=c()
psi[1]=z^2*exp(-z)/(1-exp(-z))
psi[2]=z^2*exp(-z)/(1-exp(-z))*log(z)
psi[3]=z^2*exp(-z)/(1-exp(-z))*log(z)^2
f=matrix(NA,4,4)
f[1,1]=z^2*exp(-z)/(1-exp(-z))
for(i in 2:4){
f[i,1]=deriv.Sym(psi[i-1],z)
j=2
while(j<=i){
f[i,j]=deriv.Sym(expression(f[i,j-1]/f[j-1,j-1]),z)
j=j+1
}
}
It does not report any error. However, the output shows that R isn't actually doing symbolic computation but returns characters. So I cannot evaluate the result. I tried
> i=2
> deriv.Sym(psi[i-1],z)
expression(((1 - exp(-z)) * (2 * (z * exp(-z)) - z^2 * exp(-z)) -
z^2 * exp(-z)^2)/(1 - exp(-z))^2)
> f[i,1]
[1] "( D( z , 1 ) ( ( ( z ^ 2 ) * ( Exp ( ( - z ) ) ) ) / ( 1 - ( Exp ( ( - z ) ) ) ) ) )"
It seems that deriv.Sym(psi[i-1],z) does the symbolic derivative and get the correct result. But if the result is assigned to a variable, it becomes character class. I feel confused about expression(), yacas(), Sym() and character. Anyone can point out my mistake or help me clarify these concept? Thank you so much.
Below corresponding MATLAB code for reference. The MATLAB code works just fine.
syms c;
psi(1)=c^2*exp(-c)/(1-exp(-c));
psi(2)=c^2*exp(-c)/(1-exp(-c))*log(c);
psi(3)=c^2*exp(-c)/(1-exp(-c))*log(c)^2;
f(1,1)=c^2*exp(-c)/(1-exp(-c));
for i=2:4
f(i,1)=diff(psi(i-1),c);
j=2;
while j<=i
f(i,j)=diff(f(i,j-1)/f(j-1,j-1),c);
j=j+1;
end
end
g11=matlabFunction(f(1,1));
fplot(g11,[0,10])
figure
g22=matlabFunction(f(2,2));
fplot(g22,[0,10])
figure
g33=matlabFunction(f(3,3));
fplot(g33,[0,10])
figure
g44=matlabFunction(f(4,4));
fplot(g44,[0,10])
There are several problems with the R code in the question:
it is attempting to assign an S3 object to elements of a logical matrix:
typeof(NA)
## [1] "logical"
so R has converted it to character (since Sym objects are internally
character) which is as far as it can go. f needs to be defined as a list
with 2 dimensions so that it can hold such objects:
f <- matrix(list(), 4, 4)
since f is a list with 2 dimensions all references to elements of f should use double square brackets as in:
f[[1, 1]] <- z^2 * exp(-z) / (1 - exp(-z))
similarly psi should be initialized as:
psi <- list()
and then referenced as:
psi[[1]] <- z^2 * exp(-z) / (1 - exp(-z))
to evaluate f[[i, 1]] use Eval:
Eval(f[[i, 1]], list(z = 1))
## [1] 0.2432798
This also works but overwrites the Sym object z:
z <- 1
Eval(f[[i, 1]])
in general code should be calling the generic deriv and not by directly going to the specific method deriv.Sym
The revised code is in the section at the end which makes these changes as well as some stylistic improvements.
Suggest you review the vignette that comes with Ryacas. From the R console enter:
vignette("Ryacas")
Also review the Ryacas demos:
demo(package = "Ryacas")
Revised code
# install.packages('Ryacas')
library(Ryacas)
z <- Sym("z")
psi <- list()
psi[[1]] <- z^2 * exp(-z) / (1 - exp(-z))
psi[[2]] <- z^2 * exp(-z) / (1 - exp(-z)) * log(z)
psi[[3]] <- z^2 * exp(-z) / (1 - exp(-z)) * log(z)^2
f <- matrix(list(), 4, 4)
f[[1,1]] <- z^2 * exp(-z) / (1 - exp(-z))
for(i in 2:4) {
f[[i, 1]] <- deriv(psi[[i-1]], z)
j <- 2
while(j <= i) {
f[[i, j]] <- deriv(f[[i, j-1]] / f[[j-1, j-1]], z)
j <- j + 1
}
}
i <- 2
deriv(psi[[i-1]], z)
f[[i, 1]]
Eval(f[[i, 1]], list(z = 1))