Alright, so I'm working on a small R program in order to do approximation using Halley's method. Basically I need to be able to approximate to 9 decimal places the value of 59^(1/7) using Halley's method.
What I have for the first order recurrence relation of Halley's method is this:
Xn+1 = Xn - [ f(Xn) / ( f'(Xn) - (f(Xn)f''(Xn)/2f'(Xn)) ) ]
So far this is the code I have.
halleysMethodApprox = function(ftnH, x0, m0, k0, tol = 1e-8, max.iter=2) {
x <- x0
m <- m0
k <- k0
fx <- ftnH(x, m, k)
iter <- 0
b <- fx[1]/(fx[2] - (fx[1]*fx[3])/(2*fx[2]) )
while( (abs(fx[1] - x) > tol) && (iter < max.iter) ) {
# calculate X(n+1)
b <- ( fx[1]/(fx[2] - ( (fx[1]*fx[3])/(2*fx[2]) ) ))
x <- x - b
fx <- ftnH(x, m-1, 0)
iter <- iter + 1
cat("At iteration", iter, "value of x is: ", x, "\n")
}
if( abs(x) > tol ) {
cat("Algorithm failed to converge\n")
return(NULL)
} else {
cat("Algorithm converged\n")
return(x)
}
}
and this function for generating a vector containing the function of x, and its derivatives.
ftnH = function (x, m, k) {
fx <- x^m - k
dfx <- (m*x^(m-1))
ddfx <- ((m-1)*m)*x^(m-2)
return (c(fx, dfx, ddfx))
}
print(halleysMethodApprox(ftnH, 59, (1/7), 0))
I'm not quite sure how I am supposed to numerically approximate 59^(1/7) using the above definition for Halley's method.
If you want to calculate x=59^(1/7), your function for using Halley's method is f(x) = x^7-59 = 0. And there were a few typos and minor errors in your code. Here's a corrected version:
halleysMethodApprox = function(ftnH, x0, m0, k0, tol = 1e-8, max.iter=100) {
# x0: starting estimate, eqn: x = k0^(1/m0)
x <- x0
m <- m0
k <- k0
fx <- ftnH(x0, m0, k0)
iter <- 0
b <- fx[1]/(fx[2] - (fx[1]*fx[3])/(2*fx[2]) )
while( (abs(fx[1]) > tol) && (iter < max.iter) ) {
# calculate X(n+1)
b <- ( fx[1]/(fx[2] - ( (fx[1]*fx[3])/(2*fx[2]) ) ))
x <- x - b
fx <- ftnH(x, m0, k0)
iter <- iter + 1
cat("At iteration", iter, "value of x is: ", x, "\n")
}
if(abs(fx[1]) > tol) {
cat("Algorithm failed to converge\n")
return(NULL)
} else {
cat("Algorithm converged\n")
return(x)
}
}
ftnH = function (x, m, k) {
fx <- x^m - k
dfx <- (m*x^(m-1))
ddfx <- ((m-1)*m)*x^(m-2)
return (c(fx, dfx, ddfx))
}
halleysMethodApprox(ftnH, 1, 7, 59)
# At iteration 1 value of x is: 1.320442
# At iteration 2 value of x is: 1.655396
# At iteration 3 value of x is: 1.78716
# At iteration 4 value of x is: 1.790519
# At iteration 5 value of x is: 1.790519
# Algorithm converged
# [1] 1.790519
Related
So I have the following function, which finds the root of a function using Newton-raphson method. I think my issue is relatively simple: I want the function to find the square root of a given positive number, using the newton raphson medthod. Help?
# FUNCTION:
newton <- function(f, delta = 0.0000001, x_0 = 2, n=1000){
h = 0.0000001
i = 1; x1 = x_0
p = numeric(n)
while (i <= n) { #while i is less than or equal to n(1000), continue iterations
df.dx = (f(x_0 + h) - f(x_0)) / h #
x1 = (x_0 - (f(x_0) / df.dx)) # output of original guess minus (f(x)/f´(x)) (formula for root finding)
p[i] = x1 # counts iteration so we don't exceed 1000
i = i+1 # same as ^
if (abs(x1 - x_0) < delta) break # if output is less than delta: end iteration. Otherwise continue. (x1-x_0=if new value is below our threshold, stop)
x_0 = x1
}
return(p[1: (i-1)]) #
}
############## TEST ###############
func1 <- function(x){
x^5 - 7
}
newton(func1)
#VARIABLES are
#f = the function we input
#delta = the accuracy threashold we are willing to accept
#x_0 = our initial guess
#n = the number of iterations
#h = the distance from X1 to X0,this value much little ,the root much #closed.
#abs is a sys
A possible solution :
newton <- function(f, delta = 0.0000001, x_0 = 2, n=1000){
h = 0.0000001
i = 1; x1 = x_0
p = numeric(n)
while (i <= n) { #while i is less than or equal to n(1000), continue iterations
df.dx = (f(x_0 + h) - f(x_0)) / h #
x1 = (x_0 - (f(x_0) / df.dx)) # output of original guess minus (f(x)/f´(x)) (formula for root finding)
p[i] = x1 # counts iteration so we don't exceed 1000
i = i+1 # same as ^
if (abs(x1 - x_0) < delta) break # if output is less than delta: end iteration. Otherwise continue. (x1-x_0=if new value is below our threshold, stop)
x_0 = x1
}
return(list(result = x1, iterations = p[1:i-1]))
}
nthrootsub <- function(input, nth, x){ x^nth - input}
nthroot <- function(input, nth) {newton(function(x) nthrootsub(input, nth, x))}
############## TEST ###############
10^(1/5)
#[1] 1.584893
nthroot(10,5)
#$result
#[1] 1.584893
#$iterations
#[1] 1.725000 1.605878 1.585435 1.584894 1.584893 1.584893
I'm setting up an alternative response function to the commonly used exponential function in poisson glms, which is called softplus and defined as $\frac{1}{c} \log(1+\exp(c \eta))$, where $\eta$ corresponds to the linear predictor $X\beta$
I already managed optimization by setting parameter $c$ to arbitrary fixed values and only searching for $\hat{\beta}$.
BUT now for the next step I have to optimize this parameter $c$ as well (iteratively changing between updated $\beta$ and current $c$).
I tried to write a log-lik function, score function and then setting up a Newton Raphson optimization (using a while loop)
but I don't know how to seperate the updating of c in an outer step and updating \beta in an inner step..
Are there any suggestions?
# Response function:
sp <- function(eta, c = 1 ) {
return(log(1 + exp(abs(c * eta)))/ c)
}
# Log Likelihood
l.lpois <- function(par, y, X){
beta <- par[1:(length(par)-1)]
c <- par[length(par)]
l <- rep(NA, times = length(y))
for (i in 1:length(l)){
l[i] <- y[i] * log(sp(X[i,]%*%beta, c)) - sp(X[i,]%*%beta, c)
}
l <- sum(l)
return(l)
}
# Score function
score <- function(y, X, par){
beta <- par[1:(length(par)-1)]
c <- par[length(par)]
s <- matrix(rep(NA, times = length(y)*length(par)), ncol = length(y))
for (i in 1:length(y)){
s[,i] <- c(X[i,], 1) * (y[i] * plogis(c * X[i,]%*%beta) / sp(X[i,]%*%beta, c) - plogis(c * X[i,]%*%beta))
}
score <- rep(NA, times = nrow(s))
for (j in 1:length(score)){
score[j] <- sum(s[j,])
}
return(score)
}
# Optimization function
opt <- function(y, X, b.start, eps=0.0001, maxiter = 1e5){
beta <- b.start[1:(length(b.start)-1)]
c <- b.start[length(b.start)]
b.old <- b.start
i <- 0
conv <- FALSE
while(conv == FALSE){
eta <- X%*%b.old[1:(length(b.old)-1)]
s <- score(y, X, b.old)
h <- numDeriv::hessian(l.lpois,b.old,y=y,X=X)
invh <- solve(h)
# update
b.new <- b.old + invh %*% s
i <- i + 1
# Test
if(any(is.nan(b.new))){
b.new <- b.old
warning("convergence failed")
break
}
# convergence reached?
if(sqrt(sum((b.new - b.old)^2))/sqrt(sum(b.old^2)) < eps | i >= maxiter){
conv <- TRUE
}
b.old <- b.new
}
eta <- X%*%b.new[1:(length(b.new)-1)]
# covariance
invh <- solve(numDeriv::hessian(l.lpois,b.new,y=y,X=X))
fitted <- sp(eta, b.new[length(b.new)])
result <- list("coefficients" = c(beta = b.new),
"fitted.values" = fitted,
"covariance" = invh)
}
# Running fails ..
n <- 100
x <- runif(n, 0, 1)
Xdes <- cbind(1, x)
eta <- 1 + 2 * x
y <- rpois(n, sp(eta, c = 1))
opt(y,Xdes,c(0,1,1))
You have 2 bugs:
line 25:
(y[i] * plogis(c * X[i,]%*%beta) / sp(X[i,]%*%beta, c) - plogis(c * X[i,]%*%beta))
this returns matrix so you must convert to numeric:
as.numeric(y[i] * plogis(c * X[i,]%*%beta) / sp(X[i,]%*%beta, c) - plogis(c * X[i,]%*%beta))
line 23:
) is missing:
you have:
s <- matrix(rep(NA, times = length(y)*length(par), ncol = length(y))
while it should be:
s <- matrix(rep(NA, times = length(y)*length(par)), ncol = length(y))
I have been trying to formulate a simple knapsack problem, but I cannot see why it is not working.
i <- c(1,2,3,4)
v <- c(100,80,10,120)
w <- c(10,5,10,4)
k <- 15
F <- function(i,k){
if (i==0 | k==0){
output <- 0
} else if (k<w[i]){
output <- F(i-1,w)
} else {
output <- max(v[i]+ F(i-1, k-w[i]), F(i-1,k))
}
return(output)
}
Having a look at the knapsack function of the package adagio should help you, where w is the vector of weights, p the vector of profits and cap is your k. (see ?knapsack)
knapsack <- function (w, p, cap) {
n <- length(w)
x <- logical(n)
F <- matrix(0, nrow = cap + 1, ncol = n)
G <- matrix(0, nrow = cap + 1, ncol = 1)
for (k in 1:n) {
F[, k] <- G
H <- c(numeric(w[k]), G[1:(cap + 1 - w[k]), 1] + p[k])
G <- pmax(G, H)
}
fmax <- G[cap + 1, 1]
f <- fmax
j <- cap + 1
for (k in n:1) {
if (F[j, k] < f) {
x[k] <- TRUE
j <- j - w[k]
f <- F[j, k]
}
}
inds <- which(x)
wght <- sum(w[inds])
prof <- sum(p[inds])
return(list(capacity = wght, profit = prof, indices = inds))
}
However, the problems in your function seem to be
You did not declare all the objects used in your function (w and v) : you should also declare them as parameters of your function.
F which is the name of your function is called inside your function. Hence, as (i==0 | k==0) could never be true, the function will never stop processing.
I tried running the code below.
set.seed(307)
y<- rnorm(200)
h2=0.3773427
t=seq(-3.317670, 2.963407, length.out=500)
fit=density(y, bw=h2, n=1024, kernel="epanechnikov")
integrate.xy(fit$x, fit$y, min(fit$x), t[407])
However, i recived the following message:
"Error in seq.default(a, length = max(0, b - a - 1)) :
length must be non-negative number"
I am not sure what's wrong.
I do not encounter any problem when i use t[406] or t[408] as follow:
integrate.xy(fit$x, fit$y, min(fit$x), t[406])
integrate.xy(fit$x, fit$y, min(fit$x), t[408])
Does anyone know what's the problem and how to fix it? Appreciate your help please. Thanks!
I went through the source code for the integrate.xy function, and there seems to be a bug relating to the usage of the xtol argument.
For reference, here is the source code of integrate.xy function:
function (x, fx, a, b, use.spline = TRUE, xtol = 2e-08)
{
dig <- round(-log10(xtol))
f.match <- function(x, table) match(signif(x, dig), signif(table,
dig))
if (is.list(x)) {
fx <- x$y
x <- x$x
if (length(x) == 0)
stop("list 'x' has no valid $x component")
}
if ((n <- length(x)) != length(fx))
stop("'fx' must have same length as 'x'")
if (is.unsorted(x)) {
i <- sort.list(x)
x <- x[i]
fx <- fx[i]
}
if (any(i <- duplicated(x))) {
n <- length(x <- x[!i])
fx <- fx[!i]
}
if (any(diff(x) == 0))
stop("bug in 'duplicated()' killed me: have still multiple x[]!")
if (missing(a))
a <- x[1]
else if (any(a < x[1]))
stop("'a' must NOT be smaller than min(x)")
if (missing(b))
b <- x[n]
else if (any(b > x[n]))
stop("'b' must NOT be larger than max(x)")
if (length(a) != 1 && length(b) != 1 && length(a) != length(b))
stop("'a' and 'b' must have length 1 or same length !")
else {
k <- max(length(a), length(b))
if (any(b < a))
stop("'b' must be elementwise >= 'a'")
}
if (use.spline) {
xy <- spline(x, fx, n = max(1024, 3 * n))
if (xy$x[length(xy$x)] < x[n]) {
if (TRUE)
cat("working around spline(.) BUG --- hmm, really?\n\n")
xy$x <- c(xy$x, x[n])
xy$y <- c(xy$y, fx[n])
}
x <- xy$x
fx <- xy$y
n <- length(x)
}
ab <- unique(c(a, b))
xtol <- xtol * max(b - a)
BB <- abs(outer(x, ab, "-")) < xtol
if (any(j <- 0 == apply(BB, 2, sum))) {
y <- approx(x, fx, xout = ab[j])$y
x <- c(ab[j], x)
i <- sort.list(x)
x <- x[i]
fx <- c(y, fx)[i]
n <- length(x)
}
ai <- rep(f.match(a, x), length = k)
bi <- rep(f.match(b, x), length = k)
dfx <- fx[-c(1, n)] * diff(x, lag = 2)
r <- numeric(k)
for (i in 1:k) {
a <- ai[i]
b <- bi[i]
r[i] <- (x[a + 1] - x[a]) * fx[a] + (x[b] - x[b - 1]) *
fx[b] + sum(dfx[seq(a, length = max(0, b - a - 1))])
}
r/2
}
The value given to the xtol argument, is being overwritten in the line xtol <- xtol * max(b - a). But the value of the dig variable is calculated based on the original value of xtol, as given in the input to the function. Because of this mismatch, f.match function, in the line bi <- rep(f.match(b, x), length = k), returns no matches between x and b (i.e., NA). This results in the error that you have encountered.
A simple fix, at least for the case in question, would be to remove the xtol <- xtol * max(b - a) line. But, you should file a bug report with the maintainer of this package, for a more rigorous fix.
I have a two functions one is to calculate the integration and another one is fixed-point method to find the root.This is the function to calculate the integration:
trapezoid <- function(fun, a, b, n=100) {
h <- (b-a)/n
x <- seq(a, b, by=h)
y <- fun(x)
s <- h * (y[1]/2 + sum(y[2:n]) + y[n+1]/2)
return(s)
}
And this is the root finding function:
fixedpoint <- function(fun, x0, tol=1e-03, niter=5000){
## fixed-point algorithm to find x such that fun(x) == x
## assume that fun is a function of a single variable
## x0 is the initial guess at the fixed point
xold <- x0
xnew <- fun(xold)
for (i in 1:niter) {
xold <- xnew
xnew <- fun(xold)
if ( abs((xnew-xold)) < tol )
return(xnew)
}
stop("exceeded allowed number of iterations")
}
Now I define a function f f<-function(x) {x^2}
And get its integration function h<-function(x) trapezoid(f,2,x)
Last I want to find the roots of h by doingfixedpoint(h,2)
But I got the error message like this:
Error in seq.default(a, b, by = h) : 'to' cannot be NA, NaN or
infinite