tests/testthat/test-rvar-rfun.R

In posterior: Tools for Working with Posterior Distributions

test_that("rdo works", {
  x_array <- array(1:24, dim = c(4,2,3))
  x <- new_rvar(x_array)
  y_array <- array(c(2:13,12:1), dim = c(4,3,2))
  y <- new_rvar(y_array)

  xy_ref <- new_rvar(abind::abind(along = 0,
    x_array[1,,] %*% y_array[1,,],
    x_array[2,,] %*% y_array[2,,],
    x_array[3,,] %*% y_array[3,,],
    x_array[4,,] %*% y_array[4,,]
  ))
  expect_equal(rdo(x %*% y), xy_ref)
})

test_that("rfun works", {
  x_array <- array(1:24, dim = c(4,2,3))
  x <- new_rvar(x_array)
  y_array <- array(c(2:13,12:1), dim = c(4,3,2))
  y <- new_rvar(y_array)

  xy_ref <- new_rvar(abind::abind(along = 0,
    x_array[1,,] %*% y_array[1,,],
    x_array[2,,] %*% y_array[2,,],
    x_array[3,,] %*% y_array[3,,],
    x_array[4,,] %*% y_array[4,,]
  ))
  expect_equal(rfun(function(a,b) a %*% b)(x, y), xy_ref)

  expect_error(rfun(function(a,b) a %*% b, rvar_args = "c"), "All arguments .* must be names of formal arguments of `.f`")
})

test_that("rfun works on functions without rvar arguments", {
  i <- 0
  f <- function(x) {
    i <<- i + 1
    i
  }
  expect_equal(rfun(f, rvar_args = NULL, ndraws = 10)(NULL), rvar(1:10))
})

test_that("rfun works on primitive functions", {
  x = rvar(1:10)

  rfun_sin = rfun(sin)
  expect_equal(names(formals(rfun_sin)), "x")
  expect_equal(rfun_sin(x), sin(x))
})

test_that("rfun works on dots arguments", {
  g <- function(x, y, z = 2) {
    c(x, y, z)
  }
  f <- function(x, ...) {
    g(x, ...)
  }

  expect_equal(rfun(f)(z = rvar(1:3), x = rvar(3:5), 3), c(rvar(3:5), 3, rvar(1:3)))
})

test_that("rfun works on formula functions", {
  expect_equal(rfun(~ . ^ 2)(rvar(1:3)), rvar((1:3)^2))
  expect_equal(rfun(~ .x ^ 2)(rvar(1:3)), rvar((1:3)^2))
  expect_equal(rfun(~ ..1 ^ 2)(rvar(1:3)), rvar((1:3)^2))
  expect_equal(rfun(~ .x ^ .y)(rvar(1:3), 2), rvar((1:3)^2))
  expect_equal(rfun(~ ..1 ^ ..2)(rvar(1:3), 2), rvar((1:3)^2))
})

test_that("rdo allows setting the dimensions of the result", {
  expect_equal(rdo(1:10, dim = c(2,5), ndraws = 1), rvar(array(1:10, dim = c(1,2,5))))
})

test_that("rvar_rng works", {
  set.seed(1234)

  mu <- rvar_rng(rnorm, 10, mean = 1:10, sd = 1)
  sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1)
  x <- rvar_rng(rnorm, 10, mu, sigma)

  expect_equal(mean(x), 1:10, tolerance = 0.1)
  expect_equal(apply(draws_of(x), 2, sd), rep(1.7, 10), tolerance = 0.1)
})

test_that("rvar_rng recycling works with numeric and rvar arguments", {
  # a fake random number generator that we can use to ensure draws are being
  # correctly reshaped and lined up
  rfake = function(n, tens, ones) {
    rep_len(tens * 10 + ones, length.out = n)
  }

  # numeric arguments
  ref <- rvar(array(c(11, 11, 22, 22, 13, 13, 24, 24), dim = c(2,4)))
  expect_equal(rvar_rng(rfake, 4, 1:2, 1:4, ndraws = 2), ref)

  # mixed numeric and rvar arguments
  ones <- rvar(array(1:8, dim = c(2,4)))
  ref <- rvar(array(c(11, 12, 23, 24, 15, 16, 27, 28), dim = c(2,4)))
  expect_equal(rvar_rng(rfake, 4, 1:2, ones), ref)

  # rvar arguments
  x <- c(15, 26, 37, 48)
  expect_equal(rvar_rng(rfake, 1, rvar(1:4), rvar(5:8)), rvar(x))
  expect_equal(rvar_rng(rfake, 2, rvar(1:4), rvar(5:8)), rvar(array(c(x, x), dim = c(4, 2))))

  tens <- rvar(array(1:4, dim = c(2,2)))
  ones <- rvar(array(1:8, dim = c(2,4)))
  ref <- rvar(array(c(11, 22, 33, 44, 15, 26, 37, 48), dim = c(2,4)))
  expect_equal(rvar_rng(rfake, 4, tens, ones), ref)
})

test_that("rvar_rng requires rvar arguments to be 1 dimensional", {
  expect_error(rvar_rng(rnorm, 1, as_rvar(matrix(1:4, nrow = 2))), "must be single-dimensional")
})