I have to prepare an algorithm for my thesis to cross check a theoretical result which is that the binomial model for N periods converges to lognormal distribution for N\to \infty. For those of you not familiar with the concept i have to create an algorithm that takes a starter value and multiplies it with an up-multiplier and a down multiplier and continues to do so for every value for N steps. The algorithm should return a vector whose elements are in the form of StarterValueu^id^{N-i} i=0,\dots,N
the simple algorithm i proposed is
rata<-function(N,r,u,d,S){
length(x)<-N
for(i in 0:N){
x[i]<-S*u^{i}*d^{N-i}
}
return(x)
}
N is the number of periods and the rest are just nonimportant values (u is for the up d for down etc)
In order to extract my results i need to make a histogram of the produced vector's logarithm to prove that they are normally distributed. However for a N=100000( i need an great number of steps to prove convergence) when i type hist(x) i get the error :(invalid number of breaks)
Can anyone help?? thanks in advance.
An example
taf<-rata(100000,1,1.1,0.9,1)
taf1<-log(taf)
hist(taf1,xlim=c(-400,400))
First I fix your function:
rata<-function(N,r,u,d,S){
x <- numeric(N+1)
for(i in 0:N){
x[i]<-S*u^{i}*d^{N-i}
}
return(x)
}
Or relying on vectorization:
rata<-function(N,r,u,d,S){
x<-S*u^{0:N}*d^{N-(0:N)}
return(x)
}
taf<-rata(100000,1,1.1,0.9,1)
Looking at the result, we notice that it contains NaN values:
taf[7440 + 7:8]
#[1] 0 NaN
What happened? Apparently the multiplication became NaN:
1.1^7448*0.9^(1e5-7448)
#[1] NaN
1.1^7448
#[1] Inf
0.9^(1e5-7448)
#[1] 0
Inf * 0
#[1] NaN
Why does an Inf value occur? Well, because of double overflow (read help("double")):
1.1^(7440 + 7:8)
#[1] 1.783719e+308 Inf
You have a similar problem with floating point precision when a multiplicant gets close to 0 (read help(".Machine")).
You may need to use arbitrary precision numbers.
Related
Ciao,
I am working with this function in R:
betaFun = function(x){
if(x == 0){
return(0.5)
}
return( ( 1+exp(x)*(x-1) )/( x*(exp(x)-1) ) )
}
The function is smooth and well defined for every x (at least from a theoretical point of view) and in 0 the limit approach to 0.5 (you can convince yourself about this by using Hopital theorem).
I have the following problem:
i.e. the fact that, due to the limit, R wrongly compute the values and I get a blowup in 0.
Here I report the numerical issue:
x = c(1e-4, 1e-6, 1e-8, 1e-10, 1e-12, 1e-13)
sapply(x, betaFun)
[1] 5.000083e-01 5.000442e-01 2.220446e+00 0.000000e+00 0.000000e+00 1.111111e+10
As you can see the evaluation is pretty weird, in particular last one.
I thought that I could solve this problem by defining the missing value in 0 (as you can see from the code) but it is not true.
Do you know how can I solve this numerical blow up problem?
I need high precision for this function since I have to invert it around 0. I will do it using nleqslv function from nleqslv library. Of course the inversion will return wrong solutions if the function has numerical problems.
I think that you are losing accuracy in the evaluation of exp(x)-1 for x close to 0. In C if I evaluate your function as
double f2( double x)
{ return (x==0) ? 0.5
: (x*exp(x) - expm1(x))/( x*expm1(x));
}
The problem goes away. Here expm1 is a math library function that computes exp(x) - 1, without losing accuracy for small x. I'm afraid I don't know if R has this, but you'd hope it would.
I think, though, that you would be better to test for |x| was sufficiently small, rather than 0.0. The point is that for small enough x both x*exp(x) and expm1(x) will be, as doubles, x, so their difference will be 0. To keep maximum accuracy may need to add a linear term to the 0.5 you return. I've not worked out precisely what 'sufficiently small should be, but it's somewhere around 1e-16 I think.
Your problem is that you take the quotient of two numbers with very small absolute values. Such numbers are only represented to floating point precision.
You don't specify why you need these function values for x values close to zero. One easy option would be coercion to high precision numbers:
library(Rmpfr)
betaFun = function(x){
x <- mpfr(as.character(x), precBits = 256)
#if x is calculated, you should switch to high precision numbers for its calculation
#this step could be removed then
#do calculation with high precision,
#then coerce to normal precision (assuming that is necessary)
ifelse(x == 0, 0.5, as((1 + exp(x) * (x - 1)) / (x * (exp(x) - 1)), "numeric"))
}
x = c(1e-4, 1e-6, 1e-8, 1e-10, 1e-12, 1e-13, 0)
betaFun(x)
#[1] 0.5000083 0.5000001 0.5000000 0.5000000 0.5000000 0.5000000 0.5000000
As you notice, you are encountering the problem near zero. The roots of both the numerator and denominator are zero. And as the OP mentioned, using L'Hôpitcal, you notice that in that f(x) = 1/2.
From a numerical point of view, things go slightly different. Floating points will always have an error as not every Real number can be represented as a floating point number. For example:
exp(1E-3) -1 = 0.0010005001667083845973138522822409868 # numeric
exp(1/1000)-1 = 0.001000500166708341668055753993058311563076200580... # true
^
The problem in evaluating numerically exp(1E-3)-1 already starts at the beginning, i.e. 1E-3
1E-3 = x = 0.0010000000000000000208166817117216851
exp(x) = 1.0010005001667083845973138522822409868
exp(x) - 1 = 0.0010005001667083845973138522822409868
1E-3 cannot be represented as a floating point, and is accurate upto 17 digits.
IEEE will give the closest floating point value possible to the true value of x, which already has an error due to (1). Still exp(x) is only accurate upto 17 digits.
By subtracting 1, we get a bunch of zero's in the beginning, and now our result is only accurate upto 14 digits.
So now that we know that we cannot represent everything exactly as a floating point, you should realize that near zero, it becomes a bit awkward and both numerator and denominator become less and less accurate, especially near 1E-13.
numerator_numeric(1E-13) = 1.1102230246251565E-16
numerator_true(1E-13) = 5.00000000000033333333333...E-27
Generally, what you do near such a point is use a Taylor expansion around zero, and the normal function everywhere else:
betaFun = function(x){
if(-1E-1 < x && x < 1E-1){
return(0.5 + x/12. - x^3/720. + x^5/30240.)
}
return( ( 1+exp(x)*(x-1) )/( x*(exp(x)-1) ) )
}
The above expansion is accurate upto 13 digits for x in the small region
This question is in reference is an observation from a code-golf challenge.
The submitted R solution is a working solution, but a few of us (maybe just I) seems to be dumbfounded as to why the initial X=m reassignment is necessary.
The code is golfed down a bit by #Giuseppe, so I'll write a few comments for the reader.
function(m){
X=m
# Re-assign input m as X
while(any(X-(X=X%*%m))) 0
# Instead of doing the meat of the calculation in the code block after `while`
# OP exploited its infinite looping properties to perform the
# calculations within the condition check.
# `-` here is an abuse of inequality check and relies on `any` to coerce
# the numeric to logical. See `as.logical(.Machine$double.xmin)`
# The code basically multiplies the matrix `X` with the starting matrix `m`
# Until the condition is met: X == X%*%m
X
# Return result
}
Well as far as I can tell. Multiplying X%*%m is equivalent to X%*%X since X is a just an iteratively self-multiplied version of m. Once the matrix has converged, multiplying additional copies of m or X does not change its value. See linear algebra textbook or v(m)%*%v(m)%*%v(m)%*%v(m)%*%v(m)%*%m%*%m after defining the above function as v. Fun right?
So the question is, why does #CodesInChaos's implementation of this idea not work?
function(m){while(any(m!=(m=m%*%m)))0 m}
Is this caused by a floating point precision issue? Or is this caused by the a function in the code such as the inequality check or .Primitive("any")? I do not believe this is caused by as.logical since R seems to coerce errors smaller than .Machine$double.xmin to 0.
Here is a demonstration of above. We are simply looping and taking the difference between m and m%*%m. This error becomes 0 as we try to converge the stochastic matrix. It seems to converge then blow to 0/INF eventually depending on the input.
mat = matrix(c(7/10, 4/10, 3/10, 6/10), 2, 2, byrow = T)
m = mat
for (i in 1:25) {
m = m%*%m
cat("Mean Error:", mean(m-(m=m%*%m)),
"\n Float to Logical:", as.logical(m-(m=m%*%m)),
"\n iter", i, "\n")
}
Some additional thoughts on why this is a floating point math issue
1) the loop indicates that this is probably not a problem with any or any logical check/conversion step but rather something to do with float matrix math.
2) #user202729's comment in the original thread that this issue persists in Jelly, a code golf language gives more credence to the idea that this is a perhaps a floating point issue.
The different methods iterate different functions, both starting with seed value m. Function iteration only converges to a given fixed point if that fixed point is stable and the seed is within the basin of attraction of that fixed point.
In the original code, you are iterating the function
f <- function(X) X %*% m
The limit matrix is a stable fixed-point under the assumption (stated in the Code Gulf problem) that a well-defined limit exists. Since the function definition depends on m, it isn't surprising that the fixed point is a function of m.
On the other hand, the proposed variation using m = m %*% m is obtained by iterating the function
g <- function(X) X %*% X
Note that all idempotent matrices are fixed points of this function but clearly they can't all be stable fixed points. Apparently, the limiting matrix in the original fixed function is not a stable fixed point of g (even though it is a fixed point).
To really nail this down, you would need to get into the theory of matrix fixed points under function iteration to show why the fixed point in the case of g is unstable.
This is indeed a floating point math issue. To see it, see the results of this function:
test2 <- function(m) {
c <- 0
res <- list()
while (any(m!=(m=m%*%m))) {
c <- c + 1
res[[c]] <- m
}
print(c)
res
}
To test equality with some tolerance, you can use:
test3 <- function(m) {
while (!isTRUE(all.equal(m, m <- m %*% m))) 0
m
}
I wish to numerically find the maximum of the function multiplied by Beta 3 shown on p346 of the following link when tau=30:
http://www.ssc.upenn.edu/~fdiebold/papers/paper49/Diebold-Li.pdf
They give the answer on p347 as 0.0609.
I would like to confirm this numerically in R. I.e. to take the derivative and find the value where it reaches zero.
library(numDeriv)
x <- 30
testh <- function(lambda){ ((1-exp(-lambda*30))/(lambda*30)) - exp(-lambda*30) }
grad_h <- function(lambda){
val <- grad(testh, lambda)
return(val^2)
}
OptLam <- optimize(f=grad_h, interval=c(0.0001,120), tol=0.0000000000001)
I take the square of the gradient as I want the minimum to be at zero.
Unfortunately, the answer comes back as Lambda=120!! With lambda at 120 the value of the objective function is 5.36e-12.
By working by hand I can func a lower value of the numerical derivative that is closer to zero (it is also close to the analytical value given above):
grad_h(0.05977604)
## [1] 4.24494e-12
Why is the function above not finding this lower value? I have set the tolerance very high so it should be able to find such this optimal value?
Is it possible to correct the existing method so that it gives the correct answer?
Is there a better way to find the maximum gradient of a function numerically in R?
For example is there an optimizer that looks for zero rather than trying to find a minimum of maximum?
You can use uniroot to find where the derivative is 0. This might work for you,
grad_h <- function(lambda){
val=grad(testh,lambda)
return(val)
}
## The root
res <- uniroot(grad_h, c(0,120), tol=1e-10)
## see it
ls <- seq(0.001, 1, length=1000)
plot(ls, testh(ls), col="salmon")
abline(v=res$root, col="steelblue", lwd=2, lty=2)
text(x=res$root, y=testh(res$root),
labels=sprintf("(%f, %s)", res$root,
format(testh(res$root), scientific = T)), adj=-0.1)
This question already has answers here:
Why are these numbers not equal?
(6 answers)
Closed 8 years ago.
this is the first time I'm asking a question here, so i hope you'll understand my problem.
The Thing is, that I want to do my own fft(), without using the given one in R.
So far it works well for a series like seq(1,5).
But for c(1,1) something strange happen. As far as I could point it out it seems that x - x is not 0 in that case.
Here the lines of code:
series <- c(1,1) # defining the Serie
nr_samples <- length(series) # getting the length
#################
# Calculating the harmonic frequncy
#################
harmonic <- seq(0,(nr_samples-1))
harmonic <- 2*pi*harmonic
harmonic <- harmonic/nr_samples
#################
# Exponential funktion needed for summing up
#################
exponential <- function(index, omega){
result <- exp(-((0+1i)*omega*index))
return(result)
}
#################
# The sum for calculating the fft
#################
my_fft <- function(time_series, omega){
nr_samples <- length(time_series)
summand <- 0
# In the next loop the mistakes Happens
# While running this loop for harmonic[2]
# the rseult should be 0 because
# summand = - exp_factor
# The result for summand + exp_factor
# is 0-1.22464679914735e-16i
for (i in 1:nr_samples){
exp_factor <- exponential((i-1), omega)
summand <- summand + time_series[i]*exp_factor
print(paste("Summand", summand, "Exp", exp_factor))
}
return(summand)
}
transform <- sapply(harmonic, function(x){my_fft(series,x)})
fft_transform <- fft(series)
df <- data.frame(transform, fft_transform)
print(df)
Could anyone tell me, why summand + exp_factor, for harmonic[2] is not zero??
This is commonly referred to FAQ 7.31 which says:
The only numbers that can be represented exactly in R’s numeric type are integers and fractions whose denominator is a power of 2. Other numbers have to be rounded to (typically) 53 binary digits accuracy. As a result, two floating point numbers will not reliably be equal unless they have been computed by the same algorithm, and not always even then. For example
R> a <- sqrt(2)
R> a * a == 2
[1] FALSE
R> a * a - 2
[1] 4.440892e-16
The function all.equal() compares two objects using a numeric tolerance of .Machine$double.eps ^ 0.5. If you want much greater accuracy than this you will need to consider error propagation carefully.
For more information, see e.g. David Goldberg (1991), “What Every Computer Scientist Should Know About Floating-Point Arithmetic”, ACM Computing Surveys, 23/1, 5–48, also available via http://www.validlab.com/goldberg/paper.pdf.
To quote from “The Elements of Programming Style” by Kernighan and Plauger:
10.0 times 0.1 is hardly ever 1.0.
(End of quote)
The Goldberg paper is legendary, and you may want to read it. This is a property of all floating point computation and not specific to R.
Here's my setup
obs1<-c(1,1,1)
obs2<-c(0,1,2)
obs3<-c(0,0,3)
absoluteError<-function(obs,x){
return(sum(abs(obs-x)))
}
Example:
> absoluteError(obs2,1)
[1] 2
For a random vector of observations, I'd like to find a minimizer, x, which minimizes the absolute error between the observation values and a vector of all x. For instance, clearly the argument that minimizes absoluteError(obs1,x) is x=1 because this results in an error of 0. How do I find a minimizer for a random vector of observations? I'd imagine this is a linear programming problem, but I've never implemented one in R before.
The median of obs is a minimizer for the absolute error. The following is a sketch of how one might try proving this:
Let the median of a set of n observations, obs, be m. Call the absolute error between obs and m f(obs,m).
Case n is odd:
Consider f(obs,m+delta) where delta is some non zero number. Suppose delta is positive - then there are (n-1)/2 +1 observations whose error is delta more than f(obs,m). The remaining (n-1)/2 observations' error is at most delta less than f(obs,m). So f(obs,m+delta)-f(obs,m)>=delta. (The same argument can be made if delta is negative.) So the median is the only minimizer in this case. Thus f(obs,m+delta)>f(obs,m) for any non zero delta so m is a minimizer for f.
Case n is even:
Basically the same logic as above, except in this case any number between the two inner most numbers in the set will be a minimizer.
I am not sure this answer is correct, and even if it is I am not sure this is what you want. Nevertheless, I am taking a stab at it.
I think you are talking about 'Least absolute deviations', a form of regression that differs from 'Least Squares'.
If so, I found this R code for solving Least absolute deviations regression:
fabs=function(beta0,x,y){
b0=beta0[1]
b1=beta0[2]
n=length(x)
llh=0
for(i in 1:n){
r2=(y[i]-b0-b1*x[i])
llh=llh + abs(r2)
}
llh
}
g=optim(c(1,1),fabs,x=x,y=y)
I found the code here:
http://www.stat.colostate.edu/~meyer/hw12ans.pdf
Assuming you are talking about Least absolute deviations, you might not be interested in the above code if you want a solution in R from scratch rather than a solution that uses optim.
The above code is for a regression line with an intercept and one slope. I modified the code as follows to handle a regression with just an intercept:
y <- c(1,1,1)
x <- 1:length(y)
fabs=function(beta0,x,y){
b0=beta0[1]
b1=0
n=length(x)
llh=0
for(i in 1:n){
r2=(y[i]-b0-b1*x[i])
llh=llh + abs(r2)
}
llh
}
# The commands to get the estimator
g = optim(c(1),fabs,x=x,y=y, method='Brent', lower = (min(y)-5), upper = (max(y)+5))
g
I was not familiar with (i.e., had not heard of) Least absolute deviations until tonight. So, hopefully my modifications are fairly reasonable.
With y <- c(1,1,1) the parameter estimate is 1 (which I think you said is the correct answer):
$par
[1] 1
$value
[1] 1.332268e-15
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
With y <- c(0,1,2) the parameter estimate is 1:
$par
[1] 1
$value
[1] 2
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
With y <- c(0,0,3) the parameter estimate is 0 (which you said is the correct answer):
$par
[1] 8.613159e-10
$value
[1] 3
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
If you want R code from scratch, there is additional R code in the file at the link above which might be helpful.
Alternatively, perhaps it might be possible to extract the relevant code from the source file.
Alternatively, perhaps someone else can provide the desired code (and correct any errors on my part) in the next 24 hours.
If you come up with code from scratch please post it as an answer as I would love to see it myself.
lad=function(x,y){
SAD = function(beta, x, y) {
return(sum(abs(y - (beta[1] + beta[2] * x))))
}
d=lm(y~x)
ans1 = optim(par=c(d$coefficients[1], d$coefficients[2]),method = "Nelder-Mead",fn=SAD, x=x, y=y)
coe=setNames(ans1$par,c("(Intercept)",substitute(x)))
fitted=setNames(ans1$par[1]+ans1$par[2]*x,c(1:length(x)))
res=setNames(y-fitted,c(1:length(x)))
results = list(coefficients=coe, fitted.values=fitted, residuals=res)
class(results)="lad"
return(results)
}