‘fourierin’ package

Guillermo Basulto-Elias

2016-12-05

This is a package in R to numerically calculate Fourier-type integrals of multivariate functions with compact support evaluated at regular grids. Specifically, integrals of the type

\[ I \left[f(t), \boldsymbol{a}, \boldsymbol{b};r, s \right] = \left[ \frac{|s|}{(2\pi)^{1 - r}}\right]^{n/2} \int_{a_1}^{b_1}\int_{a_2}^{b_2}\cdots\int_{a_n}^{b_n} f(\boldsymbol{t})e^{\imath s \langle \boldsymbol{w}, \boldsymbol{t}\rangle} \text{d}\boldsymbol{t}, \]

where,

\(\boldsymbol{a} = (a_1, \ldots, a_n)\), \(\boldsymbol{b} = (b_1, \ldots, b_n)\), \(\boldsymbol{t} = (t^{(1)}, \ldots, t^{(n)})\), \(\boldsymbol{w} = (w^{(1)}, \ldots, w^{(n)})\), \(a_l \leq t^{(l)} \leq b_l\), \(c_l \leq w^{(l)} \leq c_l\).

Common values for r are -1, 0 and -1, while common values for s are -2, -1, 1 and 2. For example, if f is a density function, s = 1 and r = 1 could be used to obtain the characteristic function of f. Conversely, if f is the characteristic function of a probability density function, then r = -1 and s = -1 could be used to recover the density.

The implementation of this algorithm is the one described in Inverarity (2002), Fast Computation of multidimensional Integrals.

Some examples (also found in documentation).

Example 0: Speed test

library(fourierin)
if (require(microbenchmark)) {
                                        # Test speed at several
                                        # resolutions
resolution <- 2^(0:7)
                                        # Aux. function
compute_times <- function(resol){
    out <- microbenchmark(
        fourierin_1d(f = function(t) exp(-t^2/2),
                     -5, 5, -3, 3, -1, -1, resol),
        fourierin_1d(f = function(t) exp(-t^2/2),
                     -5, 5, -3, 3, -1, -1, resol,
                     use_fft = FALSE),
        times = 5
    )
    out <- with(out, tapply(time/1e6, expr, mean))
    out <- c(out[[1]], out[[2]])
    return(out)
}
                                        # Compute the time for every
                                        # resolution
times <- t(apply(matrix(resolution), 1, compute_times))
                                        # Convert to a dataframe with
                                        # appropriate names
summ <- data.frame(resolution,
                   FFT = times[, 1], no_FFT = times[, 2])
                                        # ... And plot it
with(summ, {
    plot(range(resolution), range(c(FFT, no_FFT)), type = "n",
         xlab = "resolution", ylab = "time (milliseconds)")
    lines(resolution, FFT, type = "b", col = "cyan")
    lines(resolution, no_FFT, type = "b", col = "magenta")
    legend("topleft", legend = c("FFT", "No FFT"),
           col = c("cyan", "magenta"), lty = 1, pch = 1)
})
}
## Loading required package: microbenchmark

Example 0.1 Bivariate

library(fourierin)
if(require(microbenchmark)){
                                        # Test speed at several
                                        # resolutions
resolution <- 2^(0:6)
resolution <- cbind(resolution, resolution)
                                        # Aux. function
compute_times <- function(resol){
    out <- microbenchmark(
        fourierin(function(x)
            dnorm(x[, 1])*dnorm(x[, 2]), 
            a = c(-8, -6), b = c(6, 8),
            c = c(-4, -4), d = c(4, 4),
            r = 1, s = 1, resol = resol),
        fourierin(function(x)
            dnorm(x[, 1])*dnorm(x[, 2]), 
            a = c(-8, -6), b = c(6, 8),
            c = c(-4, -4), d = c(4, 4),
            r = 1, s = 1, resol = resol,
            use_fft = FALSE),
        times = 5
    )
    out <- with(out, tapply(time/1e9, expr, mean))
    out <- c(out[[1]], out[[2]])
    return(out)
}
                                        # Compute the time for every
                                        # resolution
times <- t(apply(resolution, 1, compute_times))
                                        # Convert to a dataframe with
                                        # appropriate names
summ <- data.frame(resolution,
                   FFT = times[, 1], no_FFT = times[, 2])
                                        # ... And plot it
with(summ, {
    plot(range(resolution), range(c(FFT, no_FFT)), type = "n",
         xlab = "resolution", ylab = "time (seconds)")
    lines(resolution, FFT, type = "b", col = "cyan")
    lines(resolution, no_FFT, type = "b", col = "magenta")
    legend("topleft", legend = c("FFT", "No FFT"),
           col = c("cyan", "magenta"), lty = 1, pch = 1)
})
}

Example 1: Recovering standard normal from its characteristic function

library(fourierin)

                                        # Compute integral
out <- fourierin(f = function(t) exp(-t^2/2),
                 a = -5, b = 5, c = -3, d = 3,
                 r = -1, s = -1, resol = 64)
grid <- out$w                           # Extract grid and values
values <- Re(out$values)

plot(grid, values, type = "l", col = 3, xlab = "x", ylab = "f(x)")
lines(grid, dnorm(grid), col = 4)
legend("topleft", legend = c("True", "Recovered"), col = c(4, 3),
      lwd = 1)

This is another example using gamma density

library(fourierin)

df <- 5
                                        # Set functions
cf <- function(t) (1 - 2i*t)^(-df/2)
dens <- function(t) dchisq(t, df)

                                        # Compute integral
out <- fourierin(f = cf,
                 a = -5, b = 5, c = -1, d = 20,
                 r = -1, s = -1, resol = 128)
grid <- out$w                           # Extract grid and values
values <- Re(out$values)

plot(grid, values, type = "l", col = 3, xlab = "x", ylab = "f(x)")
lines(grid, dens(grid), col = 4)
legend("topright", legend = c("True", "Recovered"), col = c(4, 3),
      lwd = 1)

Example 2: Computing characteristic function of a gamma density

library(fourierin)
                                        # Compute integral
shape <- 5
rate <- 3
out <- fourierin(f = function(t) dgamma(t, shape, rate),
                 a = -0, b = 8, c = -5, d = 5,
                 r = 1, s = 1, resol = 64)
grid <- out$w                           # Extract grid
re_values <- Re(out$values)             # Real values
im_values <- Im(out$values)             # Imag values

                                        # Now compute the real and
                                        # imaginary true values of the
                                        # characteric function.
true_cf <- function(t, shape, rate) (1 - 1i*t/rate)^-shape
true_re <- Re(true_cf(grid, shape, rate))
true_im <- Im(true_cf(grid, shape, rate))

                                        # Compare them. We can see a
                                        # slight discrepancy on the
                                        # tails, but that is fixed
                                        # when resulution is
                                        # increased.
plot(grid, re_values, type = "l", col = 3, xlab = "t",
     ylab = expression(paste("Re ", phi(t))))
lines(grid, true_re, col = 4)
legend("topright", legend = c("True", "Recovered"), col = c(4, 3),
      lwd = 1)

                                        # Same here
plot(grid, im_values, type = "l", col = 3, xlab = "t",
     ylab = expression(paste("Im ", phi(t))))
lines(grid, true_im, col = 4)
legend("topright", legend = c("True", "Recovered"), col = c(4, 3),
      lwd = 1)

Example 3: Recovering std. normal from its characteristic function

library(fourierin)

## Parameters of bivariate normal distribution
mu <- c(-1, 1)
sig <- matrix(c(3, -1, -1, 2), 2, 2)

## Multivariate normal density
## x is n x d
f <- function(x) {
    ## Auxiliar values
    d <- ncol(x)
    z <- sweep(x, 2, mu, "-")

    ## Get numerator and denominator of normal density
    num <- exp(-0.5*rowSums(z * (z %*% solve(sig))))
    denom <- sqrt((2*pi)^d*det(sig))

    return(num/denom)
}

## Characteristic function
## s is n x d
phi <- function(s) {
    complex(modulus = exp(- 0.5*rowSums(s*(s %*% sig))),
            argument = s %*% mu)
}

## Approximate cf using Fourier integrals
eval <- fourierin(f, a = c(-8, -6), b = c(6, 8),
                    c = c(-4, -4), d = c(4, 4),
                    r = 1, s = 1, resol = c(64, 64), use_fft = T)
t1 <- eval$w1
t2 <- eval$w2
t <- as.matrix(expand.grid(t1 = t1, t2 = t2))
approx <- eval$values
true <- matrix(phi(t), length(t1))        # Compute true values

## This is a section of the characteristic functions
i <- 33
plot(t2, Re(approx[i, ]), type = "l", col = 2,
     ylab = "",
     xlab = expression(t[2]),
     main = expression(paste("Real part section at ",
                             t[1], "= 0")))
lines(t2, Re(true[i, ]), col = 3)
legend("topleft", legend = c("true", "approximation"),
       col = 3:2, lwd = 1)

## Another section, now of the imaginary part
plot(t1, Im(approx[, i]), type = "l", col = 2,
     ylab = "",
     xlab = expression(t[1]),
     main = expression(paste("Imaginary part section at ",
                             t[2], "= 0")))
lines(t1, Im(true[, i]), col = 3)
legend("topleft", legend = c("true", "approximation"),
       col = 3:2, lwd = 1)