Given a Laplace Distribution proposal:
g(x) = 1/2*e^(-|x|)
and sample size n = 1000, I want to Conduct the Monte Carlo (MC) integration for estimating θ:
via importance sampling. Eventually I want to calculate the mean and standard deviation of this MC estimate in R once I get there.
Edit (arrived late after the answer below)
This is what I have for my R code so far:
library(VGAM)
n = 1000
x = rexp(n,0.5)
hx = mean(2*exp(-sqrt(x))*(sin(x))^2)
gx = rlaplace(n, location = 0, scale = 1)
Now we can write a simple R function to sample from Laplace distribution:
## `n` is sample size
rlaplace <- function (n) {
u <- runif(n, 0, 1)
ifelse(u < 0.5, log(2 * u), -log(2* (1 - u)))
}
Also write a function for density of Laplace distribution:
g <- function (x) ifelse(x < 0, 0.5 * exp(x), 0.5 * exp(-x))
Now, your integrand is:
f <- function (x) {
ifelse(x > 0, exp(-sqrt(x) - 0.5 * x) * sin(x) ^ 2, 0)
}
Now we estimate the integral using 1000 samples (set.seed for reproducibility):
set.seed(0)
x <- rlaplace(1000)
mean(f(x) / g(x))
# [1] 0.2648853
Also compare with numerical integration using quadrature:
integrate(f, lower = 0, upper = Inf)
# 0.2617744 with absolute error < 1.6e-05
Related
I'm trying to get the parameters w, lambda_1, lambda_2 and p from a mixture bi-exponential model, using a loglikelihood function and the optim function in R. The model is the following
Here is the code
biexpLL <- function(theta, y) {
# define parameters
w <- theta[1]
lambda_1 <- theta[2]
a <- theta[3]
lambda_2 <- theta[4]
# likelihood function with dexp
l <- w * dexp((y - a), rate = 1/lambda_1) + (1 - w) * dexp((y - a), rate = 1/lambda_2)
- sum(log(l))
}
# Generate some fake data
w <- 0.7
n <- 500
lambda_1 <- 2
lambda_2 <- 0.2
set.seed(45)
biexp_data <- (w * rexp(n, 1/lambda_1) + (1 - w) * rexp(n, 1/lambda_2))
# Optimization
optim(par = c(0.5,0.1,0.001,0.2),
fn=biexpLL,
y=biexp_data)
#$par
#[1] -94789220.4 16582.9 -333331.7 134744336.2
The parameters are very different from the used in the fake data! What I'm doing wrong?
The original code is prone to warnings and errors since the parameters may go to invalid values easily. For example, we need w in [0, 1] and lambda > 0. Also, if a is larger than a data point, then the density becomes zero, hence infinite log likelihood.
The code below uses some tricks to handle these cases.
w is converted to the range [0, 1] by the logistic function
lambda are converted to positive values by the exponential function.
Added tiny value to the likelihood to deal with cases of zero likelihood.
Also, the data generation process has been changed so that samples are generated from one of the exponential distributions with the given probability w.
Finally, increased the sample size since the result was not stable with n=500.
biexpLL <- function(theta, y) {
# define parameters
w <- 1/(1+exp(-theta[1]))
lambda_1 <- exp(theta[2])
a <- theta[3]
lambda_2 <- exp(theta[4])
# likelihood function with dexp
l <- w * dexp((y - a), rate = 1/lambda_1) + (1 - w) * dexp((y - a), rate = 1/lambda_2)
- sum(log(l + 1e-9))
}
# Generate some fake data
w <- 0.7
n <- 5000
lambda_1 <- 2
lambda_2 <- 0.2
set.seed(45)
n1 <- round(n*w)
n2 <- n - n1
biexp_data <- c(rexp(n1, rate=1/lambda_1),
rexp(n2, rate=1/lambda_2))
# Optimization
o <- optim(par=c(0.5,0.1,0.001,0.2),
fn=biexpLL,
y=biexp_data)
1/(1+exp(-o$par[1]))
exp(o$par[2])
o$par[3]
exp(o$par[4])
On my environment I obtained the below.
The result seems reasonably close to the simulation parameters (note that two lambda values are swapped).
> 1/(1+exp(-o$par[1]))
[1] 0.3458264
> exp(o$par[2])
[1] 0.1877655
> o$par[3]
[1] 3.738172e-05
> exp(o$par[4])
[1] 2.231844
Notice that for mixture models of this kind, people often use the EM algorithm for optimizing the likelihood instead of the direct optimization as this. You may want to have a look at it as well.
I have been able to get the parameters with the R package DEoptim :
library(DEoptim)
biexpLL <- function(theta, y)
{
w <- theta[1]
lambda_1 <- theta[2]
lambda_2 <- theta[3]
l <- w * dexp(y, rate = 1 / lambda_1) + (1 - w) * dexp(y, rate = 1 / lambda_2)
log_Lik <- -sum(log(l))
if(is.infinite(log_Lik))
{
return(10 ^ 30)
}else
{
return(log_Lik)
}
}
w <- 0.7
n <- 500
lambda_1 <- 2
lambda_2 <- 0.2
set.seed(45)
indicator <- rbinom(n = 500, size = 1, prob = w)
biexp_data <- (indicator * rexp(n, 1 / lambda_1) + (1 - indicator) * rexp(n, 1 / lambda_2))
obj_DEoptim <- DEoptim(fn = biexpLL, lower = c(0, 0, 0), upper = c(1, 1000, 1000), control = list(itermax = 1000, parallelType = 1), y = biexp_data)
obj_DEoptim$optim$bestmem
par1 par2 par3
0.7079678 2.2906098 0.2026040
I wanted to set a small dataframe in order to plot myself some points of the incomplete elliptic integral of 1st kind for different values of amplitude phi and modulus k. The function to integrate is 1/sqrt(1 - (k*sin(x))^2) between 0 and phi.Here is the code I imagined:
v.phi <- seq(0, 2*pi, 1)
n.phi <- length(v.phi)
v.k <- seq(-1, +1, 0.5)
n.k <- length(v.k)
k <- rep(v.k, each = n.phi, times = 1)
phi <- rep(v.phi, each = 1, times = n.k)
df <- data.frame(k, phi)
func <- function(x, k) 1/sqrt(1 - (k*sin(x))^2)
df$area <- integrate(func,lower=0, upper=df$phi, k=df$k)
But this generates errors and I am obviously mistaking in constructing the new variable df$area... Could someone put me in the right way?
You can use mapply:
df$area <- mapply(function(phi,k){
integrate(func, lower=0, upper=phi, k=k)$value
}, df$phi, df$k)
However that generates an error because there are some values of k equal to 1 or -1, while the allowed values are -1 < k < 1. You can't evaluate this integral for k = +/- 1.
Note that there's a better way to evaluate this integral: the incomplete elliptic function of the first kind is implemented in the gsl package:
> integrate(func, lower=0, upper=6, k=0.5)$value
[1] 6.458877
> gsl::ellint_F(6, 0.5)
[1] 6.458877
As I said, this function is not defined for k=-1 or k=1:
> gsl::ellint_F(6, 1)
[1] NaN
> gsl::ellint_F(6, -1)
[1] NaN
> integrate(func, lower=0, upper=6, k=1)
Error in integrate(func, lower = 0, upper = 6, k = 1) :
non-finite function value
Suppose I am seeking to integrate the following function from 0 to 10:
How would I accomplish this in R?
Functions
# Functional form
fn <- function(t) -100*(t)^2 + 20000
# First derivative w.r.t. t
fn_dt <- function(t) -200*t
# Density funciton phi
phi <- approxfun(density(rnorm(35, 15, 7)))
# Delta t
delta <- 5
How about the following:
First off, we choose a fixed seed for reproducibility.
# Density funciton phi
set.seed(2017);
phi <- approxfun(density(rnorm(35, 15, 7)))
We define the integrand.
integrand <- function(x) {
f1 <- -500 * x^2 + 100000;
f2 <- phi(x);
f2[is.na(f2)] <- 0;
return(f1 * f2)
}
By default, approxfun returns NA if x falls outside the interval [min(x), max(x)]; since phi is based on the density of a normal distribution, we can replace NAs with 0.
Let's plot the integrand
library(ggplot2);
ggplot(data.frame(x = 0), aes(x)) + stat_function(fun = integrand) + xlim(-50, 50);
We use integrate to calculate the integral; here I assume you are interested in the interval [-Inf, +Inf].
integrate(integrand, lower = -Inf, upper = Inf)
#-39323.06 with absolute error < 4.6
I estimated the cdf of my density in an interval of length 0.03 with 10k points. Even though my cdf is pretty smooth, my inverse of the cdf isn't smooth at all. Here the interval of length 1 is also evaluated with 10k points.
See: Estimated CDF & Estimated Inverse CDF
For the Inverse CDF I use:
x = seq(from = 0, to = 1, length = 10000)
F_hat_inv_given_x = function(y){
uniroot(function(x){
F_hat_given_x(x)-y
},interval=c(0.065, 0.095))$root
}
F_hat_inv_given_x = Vectorize(F_hat_inv_given_x)
with F_hat_given_x defined as:
F_hat_given_x = function(y) {
integrate(f = f_hat_given_x, min(y_data), y)$value
}
F_hat_given_x <- Vectorize(F_hat_given_x)
where f_hat_given_x is my density:
f_hat_given_x = function(y){
tapply(y, x = x_sample, FUN = f_hat, INDEX = 1:length(y))
}
which is a conditional density f(y | X = x) for a given sample X = x_sample:
f_hat = function(x, y){
(sum(K(abs(x-x_data)/H_n) * (K(abs(y-y_data)/h_n)))) / (h_n * sum(K(abs(x-x_data)/H_n)))
}
with K being the gaussian kernel, h_n, H_n are bandwidths computed via npcdensbw and x_data and y_data are my given data on which I evaluate the conditional density f_hat(x,y)
Any idea why the inverse function isn't monotone increasing like the inverse should? What is causing the inaccuracity?
Given the following function:
f(x) = (1/2*pi)(1/(1+x^2/4))
How do I identify it's distribution and write this distribution function in R?
So this is your function right now (hopefully you know how to write an R function; if not, check writing your own function):
f <- function (x) (pi / 2) * (1 / (1 + 0.25 * x ^ 2))
f is defined on (-Inf, Inf) so integration on this range gives an indefinite integral. Fortunately, it approaches to Inf at the speed of x ^ (-2), so the integral is well defined, and can be computed:
C <- integrate(f, -Inf, Inf)
# 9.869604 with absolute error < 1e-09
C <- C$value ## extract integral value
# [1] 9.869604
Then you want to normalize f, as we know that a probability density should integrate to 1:
f <- function (x) (pi / 2) * (1 / (1 + 0.25 * x ^ 2)) / C
You can draw its density by:
curve(f, from = -10, to = 10)
Now that I have the probably distribution function I was wondering how to create a random sample of say n = 1000 using this new distribution function?
An off-topic question, but OK to answer without your making a new thread. Useful as it turns out subtle.
Compare
set.seed(0); range(simf(1000, 1e-2))
#[1] -56.37246 63.21080
set.seed(0); range(simf(1000, 1e-3))
#[1] -275.3465 595.3771
set.seed(0); range(simf(1000, 1e-4))
#[1] -450.0979 3758.2528
set.seed(0); range(simf(1000, 1e-5))
#[1] -480.5991 8017.3802
So I think e = 1e-2 is reasonable. We could draw samples, make a (scaled) histogram and overlay density curve:
set.seed(0); x <- simf(1000)
hist(x, prob = TRUE, breaks = 50, ylim = c(0, 0.16))
curve(f, add = TRUE, col = 2, lwd = 2, n = 201)