rtime-seriesautoregressive-models

Simulate an AR(1) process that approximates a gamma distribution


I’d like to simulate an AR(1) time series that approximates a gamma distribution rather than a normal distribution. I’d like the result to have a specified rate and shape along with a AR(1) process with a given phi. I have seen this post and understand that a strict gamma simulation is problematic, but I'd be satisfied with a result that approximates the shape and rate. Some crude adjustment of shape and rate as a function of phi is likely enough for my needs. Any idea?

E.g.,

n <- 500
foo <- rgamma(n = n, shape = 1.5 , rate = 5)

phi <- 0.3
bar <- arima.sim(list(order = c(1,0,0), ar = phi), n = n, 
                 rand.gen = rgamma, shape = 1.5,
                 rate = 5)

ggplot() + 
  geom_density(aes(x=foo),fill="#FF8C00",alpha=0.5) + 
  geom_density(aes(x=bar),fill="#A034F0",alpha=0.5)

Solution

  • Borrowing the function from this CV answer, we can first sample from the desired distribution, then reorder the samples to approximate the expected ACF from the AR process.

    set.seed(721893540)
    
    n <- 500
    foo <- rgamma(n = n, shape = 1.5 , rate = 5)
    phi <- 0.3
    
    # match the autocorrelation for the first 4 lags, when the
    # autocorrelation (in the limit as n -> Inf) first drops below 0.01
    alpha <- phi^(0:ceiling(log(0.01)/log(0.3)))
    
    # reorder foo to get the desired ACF (ARIMA(0,0,1), phi = 0.3)
    bar <- acf.reorder(foo, alpha)
    

    The ACF of bar will match alpha more closely than would be expected from a randomly generated AR(1):

    # autocorrelation function of a random Gaussian AR(1):
    ACF <- acf(arima.sim(list(order = c(1,0,0), ar = phi), n), plot = 0)$acf
    
    data.frame(
      normal = ACF[1:length(alpha)],
      gamma = acf(bar, length(alpha) - 1, plot = 0)$acf
    )
    #>         normal      gamma
    #> 1  1.000000000 1.00000000
    #> 2  0.334034734 0.29929104
    #> 3  0.060370711 0.09063563
    #> 4  0.001948240 0.03818762
    #> 5 -0.004354808 0.01196619
    

    If this behavior is undesirable, one option is to set alpha to the ACF from a randomly generated AR(1) (until it stops decreasing monotonically).

    alpha <- ACF[1:which.max(diff(ACF) > 0)]
    bar2 <- acf.reorder(foo, alpha)
    
    data.frame(
      normal = ACF[1:length(alpha)],
      gamma = acf(bar, length(alpha) - 1, plot = 0)$acf,
      gamma2 = acf(bar2, length(alpha) - 1, plot = 0)$acf
    )
    #>         normal      gamma       gamma2
    #> 1  1.000000000 1.00000000  1.000000000
    #> 2  0.334034734 0.29929104  0.333494498
    #> 3  0.060370711 0.09063563  0.060757048
    #> 4  0.001948240 0.03818762 -0.017663549
    #> 5 -0.004354808 0.01196619  0.008826011
    

    Including acf.reorder for convenience.

    acf.reorder <- function(x, alpha) {
      tol <- 1e-5
      maxIter <- 10L
      n <- length(x)
      xx <- sort(x)
      y <- rnorm(n)
      w0 <- w <- alpha1 <- alpha
      m <- length(alpha)
      i1 <- sequence((m - 1):1)
      i2 <- sequence((m - 1):1, 2:m)
      i3 <- cumsum((m - 1):1)
      tol10 <- tol/10
      iter <- 0L
      x <- xx[rank(filter(y, w, circular = TRUE))]
      SSE0 <- Inf
      f <- function(ww) {
        sum((c(1, diff(c(0, cumsum(ww[i1]*(ww[i2]))[i3]))/sum(ww^2)) - alpha1)^2)
      }
      ACF <- function(x) acf(x, lag.max = m - 1, plot = FALSE)$acf[1:m]
      
      while ((SSE <- sum((ACF(x) - alpha)^2)) > tol) {
        if (SSE < SSE0) {
          SSE0 <- SSE
          w <- w0
        }
        if ((iter <- iter + 1L) == maxIter) break
        w1 <- w0
        a <- 0
        sse0 <- Inf
        
        while (max(abs(alpha1 - a)) > tol10) {
          a <- c(1, diff(c(0, cumsum(w1[i1]*(w1[i2]))[i3]))/sum(w1^2))
          
          if ((sse <- sum((a - alpha1)^2)) < sse0) {
            sse0 <- sse
            w0 <- w1
          } else {
            # w0 failed to converge; try optim
            w1 <- optim(w0, f, method = "L-BFGS-B")$par
            a <- c(1, diff(c(0, cumsum(w1[i1]*(w1[i2]))[i3]))/sum(w1^2))
            if (sum((a - alpha1)^2) < sse0) w0 <- w1
            break
          }
          
          w1 <- (w1*alpha1/a + w1)/2
        }
        
        x <- xx[rank(filter(y, w0, circular = TRUE))]
        alpha1 <- (alpha1*alpha/ACF(x) + alpha1)/2
      }
      
      xx[rank(filter(y, w, circular = TRUE))]
    }