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))
})