Below is the code I have. It works for primitive functions, such as sin. However, when using a function called gllik, it returns an error in f(y0): unused argument (y0). I'm not sure how to correct this.
newton_search2 <- function(f, h, guess, conv=0.001) {
y0 <- guess
N = 100
i <- 1; y1 <- y0
p <- numeric(N)
while (i <= N) {
make_derivative <- function(f, h) {
(f(y0 + h) - f(y0 - h)) / (2*h)
}
y1 <- (y0 - (f(y0)/make_derivative(f, h)))
p[i] <- y1
i <- i + 1
if (abs(y1 - y0) < conv) break
y0 <- y1
}
return (p[(i-1)])
}
The gllik function is as follows:
x <- rgamma(n=30, shape=4.5)
gllik <- function() {
s <- sum(log(x))
n <- length(x)
function(a) {
(a - 1) * s - n * lgamma(a)
}
}
The code I used was:
newton_search2(gllik, 0.001, mean(x), conv = 0.001)
I'm not sure how to fix the error or get the correct answer which is supposed to be 4.5 (the maximum liklihood estimate of a).
The problem is that gllik does not take any arguments. Furthermore, it returns a function and not a value.
Perhaps what you want to to is the following?
gllik <- function(a) {
s <- sum(log(x))
n <- length(x)
return((a - 1) * s - n * lgamma(a))
}
EDIT: An alternative solution is to just use the returned function. While this type of construction is often elegant, it does seem like overkill in this case:
newton_search2(gllik(), 0.001, mean(x), conv = 0.001)
Related
So i have this code in R that tries to double integrate a function f(x,y) using integral2, where one domain is (0.5 , +inf), but integral2 doesn't support it (because of that infinite). My question is: do you know a way to make it work?
fprob8 <- function(a , b)
{
f <- function(x , y)
{
densGamma <- function(x)
{
numitor <- b ^ a * fgam(a)
numarator <- x ^ (a - 1) * exp(-x / b)
return (numarator / numitor)
}
densBeta <- function(x)
{
numitor <- fbet(a , b)
numarator <- (1 - x) ^ (b - 1) * x ^ (a - 1)
return (numarator/numitor)
}
return (densGamma(x) * densBeta(y))
}
ymin <- function(x) # limita superioara pentru cea de-a doua integrala
{
return (min(x - 0.5),1)
}
I <- integral2(f, 0.5 , Inf , ymin , 1)
return(I)
}
Use the cubature package. It evaluates multiple integrals, allowing infinite bounds.
Here is an example:
library(cubature)
f <- function(x) exp(-x[1]-x[2])
pcubature(f, c(0,0), c(Inf,Inf))$integral
# 1
library(pracma)
f2 <- function(x,y) f(c(x,y))
integral2(f2, 0, 1000, 0, 1000, vectorized = FALSE)$Q
# 1
There is a function like:
y = (e^x - 2)^n
The x is an unknown, for n = 2,3,4,...,8
Now I want to use NR method to find the root of this function(initial x is 0).
I know how to write an NR method if the n is a fixed value, here's my origin NR code:
NR <- function(f, x0, tol = 1e-5, ite = 1000){
require(numDeriv) #call the package for computing dx
k <- ite
for (i in 1:ite){
#calculate dx
dx <- genD(func = f, x = x0)$D[1]
#get the x1
x1 <- x0 - (f(x0) / dx)
k[i] <- x1
if(abs(x1 - x0) < tol){
root <- x1
re <- list('root approximation' = root, 'iteration' = length(k))
return(re)
}
x0 <- x1
}
print('Outside the upper iteration')
}
Now I rewrite my function:
f <- function(x, n){
(exp(x) - 2) ^ n
}
If I want to output every root for different n, I think I should add another loop before the loop "for (i in 1:ite)"
So I rewrite my NR function code:
NR <- function(f, x0, tol = 1e-5, ite = 1000){
require(numDeriv) #call the package for computing dx
k <- ite
for(n in 2:8){
for (i in 1:ite){
#calculate dx
dx <- genD(func = f, x = x0)$D[1]
#get the x1
x1 <- x0 - (f(x0, n) / dx)
k[i] <- x1
if(abs(x1 - x0) < tol){
root <- x1
re <- list('root approximation' = root, 'iteration' = length(k))
return(re)
}
x0 <- x1
}
print('Outside the upper iteration')
}
}
But when I run NR(f,0), R showed me the error is :
Error in func(x, ...) : argument "n" is missing, with no default
How can I figure this out?
Thank you for your help!
I hope you find my answer helpful:
If you try ?genD you will read this:
Usage
genD(func, x, method="Richardson",
method.args=list(), ...)
## Default S3 method: genD(func, x, method="Richardson",
method.args=list(), ...) Arguments
func a function for which the first (vector) argument is used as a
parameter vector. x The parameter vector first argument to func.
And in the bottom of the R Documentation this example:
Examples
func <- function(x){c(x[1], x[1], x[2]^2)}
z <- genD(func, c(2,2,5))
Therefore, the issue with your code is that you need to use a vector as an argument for f:
f <- function(c){ (exp(c[1]) - 2) ^ c[2] }
NR <- function(f, x0, tol = 1e-5, ite = 1000){ require(numDeriv)
#call the package for computing dx k <- ite for(n in 2:8){
for (i in 1:ite){
#calculate dx
dx <- genD(func = f, x = c(x0,n))$D[1]
#get the x1
x1 <- x0 - (f(c(x0,n)) / dx)
k[i] <- x1
if(abs(x1 - x0) < tol){
root <- x1
re <- list('root approximation' = root, 'iteration' = length(k))
return(re)
}
x0 <- x1
}
print('Outside the upper iteration') } }
NR(f,0)
If I run that my output is:
$`root approximation` [1] 0.6931375
$iteration [1] 15
Best!
I am not very familiar with R. I have been trying to use the implementation of the adaptive rejection sampling method in R, in order to sample from the following distribution:
here is my R code:
library(ars)
g1 <- function(x,r){(1./r)*((1-x)^r)}
f1 <- function(x,a,k) {
add<-0
for(i in 1:k) {
add<- add+g1(x,i)
}
res <- (a* add)+(a-1)*log(x)+k*log(1-x)
return(res)
}
g2 <- function(x,r){(1-x)^(r-1)}
f1prima <- function(x,a,k) {
add<-0
for(i in 1:k) {
add<- add-g2(x,i)
}
res <- (a* add)+(a-1)/x-k/(1-x)
return(res)
}
mysample1<-ars(20,f1,f1prima,x=c(0.001,0.09),m=2,emax=128,lb=TRUE,xlb=0.0, ub=TRUE, xub=1,a=0.5,k=100)
The function is a log-concave, but I get different error messages when I run ars and fiddling around with the input parameters won't help here. Any suggestion would be appreciated.
First thing, which you already noticed is that your log-concave function is not very well defined at x=0 and x=1.0. So useful interval would be something like 0.01...0.99, not 0.0...1.0
Second, I don't like the idea to compute hundreds of terms in your summation term.
So, good idea might be to express it in following way, starting with derivative
S1N-1 qi is obviously geometric series and could be replaced with
(1-qN)/(1-q), where q=1-x.
This is derivative, so to get to similar term in function itself, just integrate it.
http://www.wolframalpha.com/input/?i=integrate+(1-q%5EN)%2F(1-q)+dq will return Gauss Hypergeometric function 2F1 plus logarithm
-qN+1 2F1(1, N+1; N+2; q)/(N+1) - log(1-q)
NB: It is the same integral as Beta before, but dealing with it was a bit more cumbersome
So, code to compute those terms:
library(gsl)
library(ars)
library(ggplot2)
Gauss2F1 <- function(a, b, c, x) {
ifelse(x >= 0.0 & x < 1.0, hyperg_2F1(a, b, c, x), hyperg_2F1(c - a, b, c, 1.0 - 1.0/(1.0 - x))/(1.0 - x)^b)
}
f1sum <- function(x, N) {
q <- 1.0 - x
- q^(N+1) * Gauss2F1(1, N+1, N+2, q)/(N+1) - log(1.0 - q)
}
f1sum.1 <- function(x, N) {
q <- 1.0 - x
res <- rep(0.0, length.out = length(x))
s <- rep(1.0, length.out = length(x))
for(k in 1:N) {
s <- s * q / as.numeric(k)
res <- res + s
}
res
}
f1 <- function(x, a, N) {
a * f1sum(x, N) + (a - 1.0)*log(x) + N*log(1.0 - x)
}
f1.1 <- function(x, a, N) {
a * f1sum.1(x, N) + (a - 1.0)*log(x) + N*log(1.0 - x)
}
f1primesum <- function(x, N) {
q <- 1.0 - x
(1.0 - q^N)/(1.0 - q)
}
f1primesum.1 <- function(x, N) {
res <- rep(0.0, length.out = length(x))
s <- rep(1.0, length.out = length(x))
for(k in 1:N) {
res <- res + s
s <- s * q
}
-res
}
f1prime <- function(x, a, N) {
a* f1primesum(x, N) + (a - 1.0)/x - N/(1.0 - x)
}
f1prime.1 <- function(x, a, N) {
a* f1primesum.1(x, N) + (a - 1.0)/x - N/(1.0 - x)
}
p <- ggplot(data.frame(x = c(0, 1)), aes(x = x)) +
stat_function(fun = f1, args = list(0.5, 100), colour = "#4271AE") +
stat_function(fun = f1.1, args = list(0.5, 100), colour = "#1F3552") +
scale_x_continuous(name = "X", breaks = seq(0, 1, 0.2), limits=c(0.001, 0.5)) +
scale_y_continuous(name = "F") +
ggtitle("Log-concave function")
p
As you can see, I've implemented both versions - one using summation and another using analytical form of sums. Computed data for a=0.5, N=100.
First, there is a bit of a difference between direct sum and 2F1 - I attribute it to precision loss in summation.
Second, more important result - function is NOT log-concave. No questions why ars() if failing left and right. See graph below
The log-likelihood of the gamma distribution with scale parameter 1 can be written as:
(α−1)s−nlogΓ(α)
where alpha is the shape parameter and s=∑logXi is the sufficient statistic.
Randomly draw a sample of n = 30 with a shape parameter of alpha = 4.5. Using newton_search and make_derivative, find the maximum likelihood estimate of alpha. Use the moment estimator of alpha, i.e., mean of x as the initial guess. The log-likelihood function in R is:
x <- rgamma(n=30, shape=4.5)
gllik <- function() {
s <- sum(log(x))
n <- length(x)
function(a) {
(a - 1) * s - n * lgamma(a)
}
}
I have created the make_derivative function as follows:
make_derivative <- function(f, h) {
(f(x + h) - f(x - h)) / (2*h)
}
I also have created a newton_search function that incorporates the make_derivative function; However, I need to use newton_search on the second derivative of the log-likelihood function and I'm not sure how to fix the following code in order for it to do that:
newton_search2 <- function(f, h, guess, conv=0.001) {
set.seed(2)
y0 <- guess
N = 1000
i <- 1; y1 <- y0
p <- numeric(N)
while (i <= N) {
make_derivative <- function(f, h) {
(f(y0 + h) - f(y0 - h)) / (2*h)
}
y1 <- (y0 - (f(y0)/make_derivative(f, h)))
p[i] <- y1
i <- i + 1
if (abs(y1 - y0) < conv) break
y0 <- y1
}
return (p[(i-1)])
}
Hint: You must apply newton_search to the first and second derivatives (derived numerically using make_derivative) of the log-likelihood. Your answer should be near 4.5.
when I run newton_search2(gllik(), 0.0001, mean(x), conv = 0.001), I get double what the answer should be.
I re-wrote the code and it works perfectly now (even better than what I had originally wrote). Thanks to all who helped. :-)
newton_search <- function(f, df, guess, conv=0.001) {
set.seed(1)
y0 <- guess
N = 100
i <- 1; y1 <- y0
p <- numeric(N)
while (i <= N) {
y1 <- (y0 - (f(y0)/df(y0)))
p[i] <- y1
i <- i + 1
if (abs(y1 - y0) < conv) break
y0 <- y1
}
return (p[(i-1)])
}
make_derivative <- function(f, h) {
function(x){(f(x + h) - f(x - h)) / (2*h)
}
}
df1 <- make_derivative(gllik(), 0.0001)
df2 <- make_derivative(df1, 0.0001)
newton_search(df1, df2, mean(x), conv = 0.001)
I have found a very subtle bug in my R code just now. The following code takes a list of objects as input and create new fields for each of the objects.
Each object originally has two fields (w, p, s, u), and then I create more, beta, phi, etc.. The normal variables are OK. However the dynamic functions (Q, K, K1, K2) are not correct. Suppose I have two nigs, nigs[[1]] and nigs[[2]], the functions Q, K, K1 and K2 for nigs[[1]] would be the same as nigs[[2]]!
I just found this bug and would consult on how to get this code correct (while keeping its elegance:) Thanks!
D <- length(nigs)
for (i in 1:D) {
w <- nigs[[i]]$w
p <- nigs[[i]]$p
s <- nigs[[i]]$s
u <- nigs[[i]]$u
nigs[[i]]$beta <- beta <- w / s * p * (1-p^2)^(-1/2);
nigs[[i]]$phi <- phi <- w^2 / s^2;
nigs[[i]]$z <- z <- (x-u)/s;
nigs[[i]]$alpha_bar <- alpha_bar <- w * (1-p^2)^(-1/2);
nigs[[i]]$y_bar <- y_bar <- sqrt(1+z^2);
nigs[[i]]$Q <- Q <- function(t) { sqrt(1 - (2*beta*t+t^2)/phi) }
nigs[[i]]$K <- K <- function(t) { u*t - w*Q(t) + w }
nigs[[i]]$K1 <- K1 <- function(t) { (u + w * (beta+t) / (Q(t)*phi)) }
nigs[[i]]$K2 <- K2 <- function(t) { qt = Q(t); (w/(qt * phi) + w * (beta+t)^2 / (qt^3 * phi^2)); }
}
EDIT
The primary error I made is that I assumed that for { } introduced new scopes, in that case, w,p,s,u are different w,p,s,u every time, actually not. Only functions in R introduce new scopes. And this scoping rule is different from C/Java.
That is normal behavior of the lexical scope.
You can use closure instead.
f <- list()
g <- list()
for (i in 1:2) {
j <- i * 2
f[[i]] <- function() print(j)
g[[i]] <- (function() {j <- j; function() print(j)}) ()
}
then,
> for (i in 1:2) f[[i]]()
[1] 4
[1] 4
> for (i in 1:2) g[[i]]()
[1] 2
[1] 4
In object oriented terminology each nigs[[i]] is an object and the functions Q, K, etc. are methods which act on the object's properties w, p, etc. Using the proto package we set each nigs[[i]] to a proto object and then update the object as indicated. Note that all methods take the object as the first argument so if p is a proto object containing method Q then p$Q(t) means to look in p for Q and then run it with the arguments p and t so p$Q(t) is the same as with(p, Q(p, t)). Thus we have added the extra first argument to each of the methods below. See proto home page for more.
library(proto)
# initialize
x <- 1
nigs <- lapply(1:2, function(i) proto(w = i/3, p = i/3, s = i/3, u = i/3))
for(p in nigs) with(p, {
beta <- w / s * p * (1-p^2)^(-1/2)
phi <- w^2 / s^2
z <- (x-u)/s
alpha_bar <- w * (1-p^2)^(-1/2)
y_bar <- sqrt(1+z^2)
Q <- function(., t) { sqrt(1 - (2*beta*t+t^2)/phi) }
K <- function(., t) { u*t - w*.$Q(t) + w }
K1 <- function(., t) { (u + w * (beta+t) / (.$Q(t)*phi)) }
K2 <- function(., t) {
qt = .$Q(t)
(w/(qt * phi) + w * (beta+t)^2 / (qt^3 * phi^2))
}
})
EDIT: A second possible design would be to create a parent object, meths to hold the methods instead of defining them over again in each separate proto object. In that case, within each method we must be sure that we use the properties of the object passed in the first argument since the methods and properties are now located in different objects:
meths <- proto(
Q = function(., t) sqrt(1 - (2*.$beta*t+t^2)/.$phi),
K = function(., t) .$u*t - .$w*.$Q(t) + .$w,
K1 = function(., t) (.$u + .$w * (.$beta+t) / (.$Q(t)*.$phi)),
K2 = function(., t) {
qt = .$Q(t)
(.$w/(qt * .$phi) + .$w * (.$beta+t)^2 / (qt^3 * .$phi^2))
}
)
# initialize - meths$proto means define proto object with parent meths
x <- 1
nigs <- lapply(1:2, function(i) meths$proto(w = i/3, p = i/3, s = i/3, u = i/3))
for(p in nigs) with(p, {
beta <- w / s * p * (1-p^2)^(-1/2)
phi <- w^2 / s^2
z <- (x-u)/s
alpha_bar <- w * (1-p^2)^(-1/2)
y_bar <- sqrt(1+z^2)
})
Now the following works by looking up Q in nigs[[1]] but not finding it there looking into its parent, meths, and running the Q found there. In nigs[[1]]$Q(.1) the call implicitly passes nigs[[1]] to Q as its first argument and we have defined all properties within the body of Q relative to the first argument so everything works:
> nigs[[1]]$Q(.1)
[1] 0.9587958