tests/testthat/test-schaferStrimmer.R

In bayesRecon: Probabilistic Reconciliation via Conditioning

test_that("Test shrinkage estimator", {
  # Parameters
  nSamples <- 500
  pTrue <- 2

  # True moments
  trueMean <- c(0, 0)
  trueSigma <- matrix(c(3, 2, 2, 2), nrow = 2)
  chol_trueSigma <- chol(trueSigma)

  # we run 100 shrinkage estimators
  lambdas <- rep(0, 100)
  for (i in seq(100)) {
    rr <- replicate(nSamples, trueMean) +
      t(chol_trueSigma) %*% matrix(stats::rnorm(pTrue * nSamples), nrow = pTrue, ncol = nSamples)
    # Estimate mean and covariance from samples
    mean_est <- rowMeans(rr)
    Sigma_est <- cov(t(rr))

    mean_est
    trueMean

    Sigma_est

    rr_centered <- rr - replicate(nSamples, mean_est)
    rowMeans(rr_centered)

    x <- t(rr)
    # x <- t(rr_centered)

    lambdas[i] <- schaferStrimmer_cov(x)$lambda_star
  }
  # The average over 100 runs must be within a certain range
  mean_lambdas <- mean(lambdas)

  # We expect this to be lower than the 99.99% quantile over 200 simulations of this scenario
  expect_lte(mean_lambdas, 0.005191634)

  # We expect this to be greater than the 0.01% quantile over 200 simulations of this scenario
  expect_gte(mean_lambdas, 0.004843328)
})

test_that("Test behavior for p=1", {
  # Parameters
  nSamples <- 500
  pTrue <- 1

  samples <- matrix(stats::rnorm(n = nSamples, sd = 2), ncol = pTrue)

  exp_sample_squared <- matrix(mean(samples^2), 1, 1)

  # The function should return E[x^2] and a warning
  expect_warning(expect_equal(schaferStrimmer_cov(samples)$shrink_cov, exp_sample_squared))
})