tests/testthat/test-gibbs_kcycle.R

In systemicrisk: A Toolbox for Systemic Risk

context("Test of ERE_step_cycle")

set.seed(123787)
gen1stepGibbs <- function(p,lambda,steps=5,k=3){
  n <- dim(p)[1]
  M <- matrix(rbinom(n^2,size=1,prob=p)*rexp(n^2,rate=lambda),nrow=n)
  Mstep <- cloneMatrix(M)
  res <- list(M=M)
  for (i in 1:steps){
    r=sample(0:(n-1),k,replace=FALSE)
    col=sample(0:(n-1),k,replace=FALSE)
    tryCatch(
             ERE_step_cycle(r=r,c=col,L=Mstep, p=p,lambda=lambda),error=function(cond){browser()})
    if (!all(Mstep>=0))
      expect_true(all(Mstep>=0))
  }
  res$Mstep=Mstep
  res
}

test <- function(x,p,lambda){
  n <- dim(p)[1]

  expect_equal(rowMeans(x[1:n^2,]==0),rowMeans(x[(n^2+1):(2*n^2),]==0),scale=1,tolerance=1e-2,check.attributes = FALSE)
  expect_equal(rowMeans(x[1:n^2,]),rowMeans(x[(n^2+1):(2*n^2),]),scale=1,tolerance=1e-2,check.attributes = FALSE)

  for (i in 1:n^2){
    if (p[i]>0){
      expect_equal(mean(x[i,x[i,]>0]),1/lambda[i],tolerance=2e-2,label=paste("Mean conditional on positive value, Initial sample, i=",i,"\n"))
      expect_equal(mean(x[i+n^2,x[i+n^2,]>0]),1/lambda[i],tolerance=2e-2,label=paste("Mean conditional on positive value, after Gibbs steps, i=",i,"\n"))
    }
  }
}
testrun <- function(p,lambda,nrep=1e5,k=2){
  n <- dim(p)[1]
  x <- replicate(nrep,unlist(gen1stepGibbs(p,lambda,k=k)))
  test(x,p,lambda)
}

test_that("All probabilities equal, ps equal to 1, lambdas equal to 1",{
  skip_on_cran()

  p <- matrix(1,nrow=3,ncol=3)
  diag(p)=0;
  lambda <- matrix(1,nrow=3,ncol=3)
  testrun(p=p,lambda=lambda,k=3)
  testrun(p=p,lambda=lambda,k=2)
})



test_that("All probabilities equal, lambdas equal to 1, p=0.4",{
  skip_on_cran()

  p <- matrix(0.4,nrow=3,ncol=3)
  lambda <- matrix(1,nrow=3,ncol=3)
  testrun(p=p,lambda=lambda,k=2)
  testrun(p=p,lambda=lambda,k=3)
})

test_that("All probabilities equal, lambdas equal to 1, p=0.9 ",{
  skip_on_cran()

  p <- matrix(0.9,nrow=3,ncol=3)
  lambda <- matrix(1,nrow=3,ncol=3)
  testrun(p=p,lambda=lambda,k=2,nrep=3e5)
  testrun(p=p,lambda=lambda,k=3,nrep=3e5)
})


test_that("All probabilities and lambdas equal, p=0.8 ",{
  skip_on_cran()

  p <- matrix(0.8,nrow=3,ncol=3)
  lambda <- matrix(2,nrow=3,ncol=3)
  testrun(p=p,lambda=lambda,k=2,nrep=3e5)
  testrun(p=p,lambda=lambda,k=3,nrep=3e5)
})

test_that("Example with varying p and lambda",{
  skip_on_cran()

  p <- matrix(seq(0.1,1,length.out=9),nrow=3,ncol=3)
  lambda <- matrix(1/(1:9),nrow=3,ncol=3)
  testrun(p=p,lambda=lambda,k=2,nrep=2e5)
  testrun(p=p,lambda=lambda,k=3,nrep=2e5)
})

test_that("Example with varying high p and lambda",{
  skip_on_cran()

  p <- matrix(seq(0.6,1,length.out=9),nrow=3,ncol=3)
  diag(p)=0;
  lambda <- matrix(1/(1:9),nrow=3,ncol=3)
  testrun(p=p,lambda=lambda)
})