tests/testthat/test-simulation-helpers.R

In binsreg: Binscatter Estimation and Inference

legacy_binsreg_pval <- function(num, denom, reps, tstat=NULL, side=NULL, alpha, lp=Inf) {
  tvec <- c()
  pval <- NA
  if (!is.null(tstat)) pval <- numeric(nrow(tstat))
  cval <- NA
  k <- ncol(num)

  for (i in seq_len(reps)) {
    eps <- matrix(rnorm(k, 0, 1), ncol = 1)
    tx <- (num %*% eps) / denom

    if (!is.null(side)) {
      if (side == "two") {
        if (is.infinite(lp)) tvec[i] <- max(abs(tx))
        else                 tvec[i] <- mean(abs(tx)^lp)^(1/lp)
      } else if (side == "left") {
        tvec[i] <- max(tx)
      } else if (side == "right") {
        tvec[i] <- min(tx)
      }
    }

    if (!is.null(tstat)) {
      for (j in seq_len(nrow(tstat))) {
        if (tstat[j, 2] == 1) {
          pval[j] <- pval[j] + (max(tx) >= tstat[j, 1])
        } else if (tstat[j, 2] == 2) {
          pval[j] <- pval[j] + (min(tx) <= tstat[j, 1])
        } else if (tstat[j, 2] == 3) {
          if (is.infinite(lp)) pval[j] <- pval[j] + (max(abs(tx)) >= tstat[j, 1])
          else                 pval[j] <- pval[j] + (mean(abs(tx)^lp)^(1/lp) >= tstat[j, 1])
        }
      }
    }
  }

  if (!is.null(tstat)) pval <- pval / reps
  if (!is.null(side)) cval <- quantile(tvec, alpha/100, na.rm=TRUE, names=FALSE, type=2)
  list(pval=pval, cval=cval)
}

legacy_binspwc_pval <- function(nummat1, nummat2, denom1, denom2, reps, tstat=NULL, testtype=NULL, lp=Inf, alpha=95) {
  pval <- 0
  tvec <- c()
  k1 <- ncol(nummat1)
  k2 <- ncol(nummat2)

  for (i in seq_len(reps)) {
    eps1 <- matrix(rnorm(k1, 0, 1), ncol = 1)
    eps2 <- matrix(rnorm(k2, 0, 1), ncol = 1)
    tx <- (nummat1 %*% eps1 - nummat2 %*% eps2) / sqrt(denom1^2+denom2^2)

    if (testtype == "left") {
      pval <- pval + (max(tx) >= tstat)
    } else if (testtype == "right") {
      pval <- pval + (min(tx) <= tstat)
    } else {
      if (is.infinite(lp)) pval <- pval + (max(abs(tx)) >= tstat)
      else                 pval <- pval + (mean(abs(tx)^lp)^(1/lp) >= tstat)
    }

    tvec[i] <- max(abs(tx))
  }

  list(
    pval=pval/reps,
    cval.cb=quantile(tvec, alpha/100, na.rm=TRUE, names=FALSE, type=2)
  )
}

test_that("binsreg.pval preserves the legacy simulation stream", {
  num <- matrix(c(
    0.4, -0.2, 0.7,
    1.1, 0.5, -0.3,
    -0.6, 0.9, 0.2,
    0.3, -0.8, 0.6
  ), nrow=4, byrow=TRUE)
  denom <- c(1.2, 0.9, 1.5, 1.1)
  tstat <- matrix(c(0.4, 1, -0.3, 2, 0.8, 3), ncol=2, byrow=TRUE)

  set.seed(60201)
  expected <- legacy_binsreg_pval(num, denom, 37, tstat=tstat, side="two", alpha=95, lp=Inf)
  set.seed(60201)
  observed <- binsreg:::binsreg.pval(num, denom, 37, tstat=tstat, side="two", alpha=95, lp=Inf)

  expect_equal(observed, expected, tolerance=1e-12)
})

test_that("binspwc.pval preserves the legacy simulation stream", {
  nummat1 <- matrix(c(
    0.1, 0.3, -0.5,
    0.7, -0.2, 0.4,
    -0.6, 0.8, 0.2,
    0.4, -0.1, 0.9
  ), nrow=4, byrow=TRUE)
  nummat2 <- matrix(c(
    -0.2, 0.6,
    0.5, -0.4,
    0.8, 0.1,
    -0.3, 0.7
  ), nrow=4, byrow=TRUE)
  denom1 <- c(1.0, 1.3, 0.8, 1.1)
  denom2 <- c(0.9, 0.7, 1.2, 1.4)

  set.seed(60202)
  expected <- legacy_binspwc_pval(nummat1, nummat2, denom1, denom2, 41, tstat=0.75, testtype="two-sided", alpha=95)
  set.seed(60202)
  observed <- binsreg:::binspwc.pval(nummat1, nummat2, denom1, denom2, 41, tstat=0.75, testtype="two-sided", alpha=95)

  expect_equal(observed, expected, tolerance=1e-12)
})