This question already has answers here:
Is floating point math broken?
(31 answers)
Closed 4 years ago.
The function follows:
qual <- function(x, y, z)
{if ((abs(x - y) <= .15)&(abs(x - z) <= .15)&(abs(y - z) <= .15)){print("grade A")}
else if((abs(x - y) <= .15)|(abs(x - z) <= .15)){print("grade B")}
else if((abs(x - y) <= .2)|(abs(x - z) <= .2)){print("grade C")}
else if((abs(x - y) <= .25)|(abs(x - z) <= .25)){print("grade D")}
else {print("check manually")}}
It seems that, e.g., the output of qual(1.19, 1.04, 1.06) and qual(1.10, .95, .97)should be "grade A". However, the output is "grade A" and "grade B", respectively.
Why is this?
I think you are hitting some floating point precision problems. See Why are these numbers not equal for a full explanation.
To fix this, you can use a short function that takes into account minor precision errors when comparing:
less_equal_safe <- function(x, y) {
(x < y) | dplyr::near(x, y)
}
qual <- function(x, y, z) {
if (less_equal_safe(abs(x - y), .15) & (abs(x - z) <= .15) &(abs(y - z) <= .15)) {
print("grade A")
} else if ((abs(x - y) <= .15) | (abs(x - z) <= .15)) {
print("grade B")
} else if ((abs(x - y) <= .2) | (abs(x - z) <= .2)) {
print("grade C")
}
else if ((abs(x - y) <= .25) | (abs(x - z) <= .25)) {
print("grade D")
} else {
print("check manually")
}
}
(note that you need the dplyr package to be installed to use dplyr::near)
I've only replaced the first comparison, which is the one that was causing the issue, but ideally you should replace all comparisons in your function with the float-safe function.
Related
I have this exercise and I cant figure it out.
Create a function ans(x, y, c) which returns the value c*x^2*y, if x^2 <= y <= 1, and the value 0 otherwise. When you are ready input c.
I have 2 different solutions but I can't quite understand how to organize the function correctly. Neither one is correct.
Solution 1)
ans <- function(x,y,c){
if (x^2 <= y && <= 1)
return(c*x^2*y)
}
else{
return(0)
}
Solution 2)
ans <- function(x,y,c){
if (x^2 <= y & y <= 1)
return(c*x^2*y)
else if(x^2 <= 1){
return(c*x^2*y)
}
else{}
return(0)
}
Just check the format of your function. Here may be something you want:
ans <- function(x,y,c){
if (x^2 <= y & y <= 1){
return(c*x^2*y)
}else{return(0)}}
I have a log-likelihood function I would like to optimize and understood I could do so with optim() in R. The parameters my function requires is a vector of probabilities (of length N) as well as a symmetric matrix of size N*N (where only N-choose-2 (right now N=5) values matter, due to the symmetry).
When I try using optim() I receive the following error:
Error in optim(params, L) : (list) object cannot be coerced to type 'double'
Why do I receive this error and how can I make this work?
(If there is a better solution in Matlab or Python, references or suggestions for functions in these languages are welcome too)
Here is the code:
numerator <- function(P, Gamma, y, U, N) {
expr = 1
for (i in 1:N-1) {
for ( j in i+1:N) {
if ((y[i] == y[j]) & (y[i] == 1)) {
expr = expr*P[i]*P[j]*exp(Gamma[i,j])
}
if ((y[i] != y[j]) & (y[i] == 1)) {
expr = expr*P[i]*(1 - P[j])
}
if ((y[i] != y[j]) & (y[i] == 0)) {
expr = expr*(1 - P[i])*P[j]
}
if ((y[i] == y[j]) & (y[i] == 0)) {
expr = expr*(1 - P[i]*P[j]*exp(Gamma[i,j]) - P[i]*(1 - P[j]) - (1 - P[i])*P[j])
}
}
}
return(expr)
}
denominator <- function(params, y, U, N) {
P <- params$probs
val <- 1
for (i in 1:N-1) {
val <- val*(y[i]*P[i]^(N-3) + (1-y[i])*(1 - P[i])^(N-3))
}
val <- val * y%*%P + (1 - y)%*%(1 - P)
return(val)
}
L <- function(params, y, U, N) {
P <- params$probs
Gamma <- params[,2:(N+1)]
n <- log(numerator(P, Gamma, y, U, N))
d <- log(denominator(P, y, U, N))
l <- n-d
return(l)
}
y <- readRDS(file="purchase_records_df.rds")
N <- ncol(y)
params <- data.frame('probs'=rep(0.001, N), 'gamma'=matrix(0,nrow=N,ncol=N))
optim(params, L)
Briefly, the setting is y is a vector of purchases, but here we want to take our purchase data and find the underlying probabilities.
Thank you very much!
I'm trying to write a square root function in R. The function is supposed to behave like sqrt() but not use that function of course. I'm supposed to use Newton's method for computing the square root, which is:
y(a+1) = [y(a) + x / y(a)]/2
Here x is the number I'm trying to calculate the square root of and y(0) would be the initial guess of the square root of x.
The function is supposed to take in four arguments: x (the number I'm trying to compute the square root of), eps (the difference in value between iterations that are considered be equal), iter (the max number of iterations), and verbose (says I want to output intermediate results).
My issue is that I am not very well versed in writing functions in R. I have experience in C++, but they are slightly different in R.
I believe I'm supposed to write something that goes like this.
Asks the user to input a number as a guess for the value we want to calculate the square root of. Make a for loop from 1 to iter with two if statements 1) that stop the function and output the y value if the max number of iterations have been reached 2) stop the function and output the y value if the difference between successive iterations is less than eps.
Here is the code I have so far:
MySqrt <- function (x, eps = 1e-6, iter = 100, verbose = TRUE) {
for (i in 0:itmax) {
y[0] <- readline(prompt="Please enter your initial square root guess: ")
y[i + 1] = (y[i] + x / y[i])/2
if (i == 100) {
stop (return(y[i + 1]))
}
if (abs(y[i + 1] - y[i]) < eps) {
stop (return(y[i + 1]))
}
}
return(y[i + 1])
}
Here is the error I receive after entering the initial square root guess: Error in y[0] <- readline(prompt = "Please enter your initial square root guess: ") :
object 'y' not found
Honestly, I didn't expect the code to work because I'm sure there are more than one errors.
You should use iter instead of itmax.
I initialized y within the function and input of y should be formatted as a number instead of a character. You could also simplify the if statement by using | (or).
I also added "cat" function so you could see what i is before the function prints out the square root value.
MySqrt <- function (x, eps = 1e-6, iter = 100, verbose = TRUE) {
y = 0
y[1] = as.numeric(readline(prompt="Please enter your initial square root guess: "))
for (i in 1:iter) {
y[i+1] = as.numeric((y[i] + (x/y[i]))/2)
if (i == 100 || abs(y[i+1] - y[i]) < eps) {
cat("This is", i,"th try: \n")
return(y[i+1])
}
}
}
Try this simply:
newton.raphson <- function(x, start, epsilon=0.0001, maxiter=100) {
y <- c(start) # initial guess
a <- 1 # number of iterations
while (TRUE) {
y <- c(y, (y[a] + x / y[a])/2)
if (abs(y[a+1] - y[a]) < epsilon | a > maxiter) { # converged or exceeded maxiter
return(y[a+1])
}
a <- a + 1
}
}
newton.raphson(2, 0.5, 0.01)
# [1] 1.414234
newton.raphson(3, 0.5, 0.01)
# [1] 1.732051
since sqrt(n) < n/2 then with precision of 1/10000
sqrnt=function(y){
x=y/2
while (abs(x*x-y) > 1e-10)
{x=(x+y/x)/2 }
x
}
In Newton’s method. If you want to know the square root of a, you can start estimate a number, x (for examples a/2), you can compute a better estimate with the following formula:
y = (x + a / x) / 2
If y != x, you set x = y, and repeat until y == x. Then you get the square root of a. Please see the code below:
square_root <- function(a) {
x <- a/2
while (TRUE) {
y <- (x + a / x) / 2
if (y == x) break
x <- y
}
return(y)
}
Is there any implementation of functionality in R, such that it is possible to get the next representable floating point number from a given floating point number. This would be similar to the nextafter function in the C standard library. Schemes such as number + .Machine$double.eps don't work in general.
No, but there are two ways you can make it:
Using C
If you want the exact functionality of the nextafter() function, you can write a C function that works as an interface to the function such that the following two constraints are met:
The function does not return a value. All work is accomplished as a "side effect" (changing the values of arguments).
All the arguments are pointers. Even scalars are vectors (of length one) in R.
That function should then be compiled as a shared library:
R CMD SHLIB foo.c
for UNIX-like OSs. The shared library can be called using dyn.load("foo.so"). You can then call the function from inside R using the .C() function
.C("foo", ...)
A more in depth treatment of calling C from R is here.
Using R
number + .Machine$double.eps is the way to go but you have to consider edge cases, such as if x - y < .Machine$double.eps or if x == y. I would write the function like this:
nextafter <- function(x, y){
# Appropriate type checking and bounds checking goes here
delta = y - x
if(x > 0){
factor = 2^floor(log2(x)) + ifelse(x >= 4, 1, 0)
} else if (x < 0) {
factor = 65
}
if (delta > .Machine$double.eps){
return(x + factor * .Machine$double.eps)
} else if (delta < .Machine$double.eps){
return(x - factor * .Machine$double.eps)
} else {
return(x)
}
}
Now, unlike C, if you want to check integers, you can do so in the same function but you need to change the increment based on the type.
UPDATE
The previous code did not perform as expected for numbers larger than 2. There is a factor that needs to be multiplied by the .Machine$double.eps to make it large enough to cause the numbers to be different. It is related to the nearest power of 2 plus one. You can get an idea of how this works with the below code:
n <- -100
factor <- vector('numeric', 100)
for(i in 1:n){
j = 0
while(TRUE){
j = j + 1
if(i - j * .Machine$double.eps != i) break()
}
factor[i] = j
}
If you prefer Rcpp:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
double nextAfter(double x, double y) {
return nextafter(x, y);
}
Then in R:
sprintf("%.20f", 1)
#[1] "1.00000000000000000000"
sprintf("%.20f", nextAfter(1, 2))
#[1] "1.00000000000000022204"
I'm not sure if Christopher Louden's answer works for all values, but here's a pure R version of the classic approach (increments/decrements the integer bits). R does not make it easy to convert between doubles and integers, nor does it have a 64-bit integer type, so there's quite a lot of code for this.
doubleToRaw <- function(d) writeBin(d, raw());
rawToDouble <- function(r) readBin(r, numeric());
int64inc <- function(lo, hi) {
if (lo == 0xffffffff) { hi <- hi + 1; lo <- 0; } else { lo <- lo + 1; }
return(c(lo, hi));
}
int64dec <- function(lo, hi) {
if (lo == 0) { hi <- hi - 1; lo <- 0xffffffff; } else { lo <- lo - 1; }
return(c(lo, hi));
}
nextafter <- function(x, y) {
if (is.nan(x + y))
return(NaN);
if (x == y)
return(x);
if (x == 0)
return(sign(y) * rawToDouble(as.raw(c(0, 0, 0, 0, 0, 0, 0, 1))));
ints <- packBits(rawToBits(doubleToRaw(x)), "integer")
if ((y > x) == (x > 0))
ints <- int64inc(ints[1], ints[2])
else
ints <- int64dec(ints[1], ints[2]);
return(rawToDouble(packBits(intToBits(ints), "raw")))
}
I am using Sage to (within a script) solve a simple equation in two variables:
sage: x, y = var("x y")
sage: p = x*y + x/y + 1/x
sage: diff(p, x)
y + 1/y - 1/x^2
sage: diff(p, y)
x - x/y^2
sage: solve([diff(p,x)==0, diff(p,y)==0], [x,y])
[[x == 0, y == 0], [x == -1/2*sqrt(2), y == 1],
[x == 1/2*sqrt(2), y == 1], [x == -1/2*I*sqrt(2), y == -1],
[x == 1/2*I*sqrt(2), y == -1]]
For some reason, Sage returns a solution that isn't a solution at all, here [x == 0, y == 0] can easily be seen NOT to be an answer of [y + 1/y - 1/x^2 == 0, x - x/y^2 == 0].
Is this a bug? a known bug? or am I doing something wrong?
UPDATE: rephrased the title, and I am wondering, worst case, how can I substitute the solutions back in the system to manually check if the equations are verified?
PS: I would post this on AskSage, but it is currently down.
Well, looks like Maxima's solve function is returning the spurious solution [x = 0, y = 0]. I see that Maxima's to_poly_solve is better behaved here.
p : x*y + x/y + 1/x;
load (to_poly_solve);
[dpx, dpy] : [diff (p, x), diff (p, y)];
to_poly_solve ([dpx, dpy], [x, y]);
=> %union([x = -1/sqrt(2),y = 1],[x = 1/sqrt(2),y = 1],
[x = -%i/sqrt(2),y = -1],[x = %i/sqrt(2),y = -1])
for xy in args (%) do print (subst (xy, [dpx, dpy]));
=>
[0,0]
[0,0]
[0,0]
[0,0]
I don't know how to call to_poly_solve from Sage, although I'm pretty sure it's possible.
Hope this helps. Good luck & have fun.