tests/testthat/test-method_cbps.R

In WeightIt: Weighting for Covariate Balance in Observational Studies

test_that("Binary treatment", {
  skip_on_cran() #many tests, take too long
  skip_if_not_installed("rootSolve")
  skip_if_not_installed("cobalt")

  eps <- if (capabilities("long.double")) 1e-5 else 1e-1

  test_data <- readRDS(test_path("fixtures", "test_data.rds"))

  expect_no_condition({
    W0 <- weightit(A ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9,
                   data = test_data, method = "cbps", estimand = "ATE",
                   include.obj = TRUE, solver = "optim")
  })

  sw.opts <- c(FALSE, TRUE)
  over.opts <- c("exact", "twostep", "cont")
  estimand.opts <- c("ATE", "ATT", "ATC", "ATO")
  link.opts <- c("logit", "probit", "loglog", "cauchit")

  weight.mat <- matrix(nrow = nrow(test_data),
                       ncol = length(sw.opts) * length(over.opts) *
                         length(estimand.opts) * length(link.opts))
  colnames(weight.mat) <- rep("", ncol(weight.mat))
  k <- 1

  for (sw in sw.opts) {
    for (over in over.opts) {
      for (estimand in estimand.opts) {
        for (link in link.opts) {
          expect_no_condition({
            suppressWarnings({
            W <- weightit(A ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9,
                          data = test_data, method = "cbps", estimand = estimand,
                          over = over != "exact", twostep = if (over == "exact") NULL else over == "twostep",
                          link = link,
                          s.weights = if (sw) "SW" else NULL,
                          include.obj = TRUE, solver = "multiroot")
            })
          })

          n <- sprintf("W_%s_%s_%s_%s", sw, over, estimand, link)
          assign(n, W)

          if (over == "exact") {
            expect_M_parts_okay(W, tolerance = eps)
            expect_equal(cobalt::col_w_smd(W$covs, W$treat, W$weights,
                                           s.weights = W$s.weights),
                         0 * cobalt::col_w_smd(W$covs, W$treat,
                                               s.weights = W$s.weights),
                         label = sprintf("SMDs for %s", n),
                         expected.label = "all 0s",
                         tolerance = eps)
          }

          expect_true(is.numeric((!!{{ str2lang(n) }})$ps))
          expect_false(is_null((!!{{ str2lang(n) }})$obj))

          for (i in 0:1) {
            e <- {
              if (estimand == "ATT" && i == 1) expect_equal
              else if (estimand == "ATC" && i == 0) expect_equal
              else expect_not_equal
            }

            e(W$weights[W$treat == i],
              rep(1, sum(W$treat == i)),
              label = sprintf("%s weights for %s", i, n),
              expected.label = "all 1s",
              tolerance = eps)
          }

          if (link != "logit" || estimand != "ATO") {
            for (i in seq_len(k)) {
              expect_not_equal(W$weights, weight.mat[,i],
                               label = sprintf("Weights for %s", n),
                               expected.label = sprintf("weights for model %s", colnames(weight.mat)[i]),
                               tolerance = min(1e-8, eps))
            }
          }

          weight.mat[,k] <- W$weights
          colnames(weight.mat)[k] <- n
          k <- k + 1
        }
      }
    }
  }

  # Estimands
  expect_error({
    W <- weightit(A ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9,
                  data = test_data, method = "cbps", estimand = "ATM")
  }, "not an allowable estimand")

  #Non-full rank
  expect_no_condition({
    W <- weightit(A ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9 +
                    I(1 - X5) + I(X9 * 2),
                  data = test_data, method = "cbps", estimand = "ATE",
                  include.obj = TRUE)
  })

  expect_equal(W$weights, W0$weights, tolerance = eps)
})

test_that("Multi-category treatment", {
  skip_on_cran() #many tests, take too long
  skip_if_not_installed("rootSolve")
  skip_if_not_installed("cobalt")

  eps <- if (capabilities("long.double")) 1e-5 else 1e-1

  test_data <- readRDS(test_path("fixtures", "test_data.rds"))

  expect_no_condition({
    W0 <- weightit(Am ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9,
                   data = test_data, method = "cbps", estimand = "ATE",
                   include.obj = TRUE, solver = "optim")
  })

  sw.opts <- c(FALSE, TRUE)
  over.opts <- c("exact", "twostep", "cont")
  estimand.opts <- c("ATE", "ATT", "ATO")

  weight.mat <- matrix(nrow = nrow(test_data),
                       ncol = length(sw.opts) * length(over.opts) *
                         length(estimand.opts))
  colnames(weight.mat) <- rep("", ncol(weight.mat))
  k <- 1

  for (sw in sw.opts) {
    for (over in over.opts) {
      for (estimand in estimand.opts) {
        expect_no_error({
          suppressWarnings({
          W <- weightit(Am ~ X1 + X2 + X3 + X4 + X5,
                        data = test_data, method = "cbps", estimand = estimand,
                        over = over != "exact", twostep = if (over == "exact") NULL else over == "twostep",
                        focal = if (estimand == "ATT") "T" else NULL,
                        s.weights = if (sw) "SW" else NULL,
                        include.obj = TRUE, solver = "multiroot")
          })
        })

        n <- sprintf("W_%s_%s_%s", sw, over, estimand)
        assign(n, W)

        if (over == "exact") {
          expect_M_parts_okay(W, tolerance = eps)
          for (tt in combn(levels(W$treat), 2, simplify = FALSE)) {
            in_tt <- W$treat %in% tt
            expect_equal(cobalt::col_w_smd(W$covs[in_tt,], W$treat[in_tt], W$weights[in_tt],
                                           s.weights = W$s.weights[in_tt]),
                         0 * cobalt::col_w_smd(W$covs[in_tt,], W$treat[in_tt],
                                               s.weights = W$s.weights[in_tt]),
                         label = sprintf("SMDs for %s", n),
                         expected.label = "all 0s",
                         tolerance = eps)
          }
        }

        expect_true(is_null((!!{{ str2lang(n) }})$ps))
        expect_false(is_null((!!{{ str2lang(n) }})$obj))

        for (i in levels(W$treat)) {
          e <- {
            if (estimand == "ATT" && i == W$focal) expect_equal
            else expect_not_equal
          }

          e(W$weights[W$treat == i],
            rep(1, sum(W$treat == i)),
            label = sprintf("%s weights for %s", i, n),
            expected.label = "all 1s",
            tolerance = eps)
        }

        for (i in seq_len(k - 1)) {
          expect_not_equal(W$weights, weight.mat[,i],
                           label = sprintf("Weights for %s", n),
                           expected.label = sprintf("weights for %s", colnames(weight.mat)[i]),
                           tolerance = min(1e-8, eps))
        }

        colnames(weight.mat)[k] <- n
        weight.mat[,k] <- W$weights
        k <- k + 1

        rm(list = n)
      }
    }
  }
})

test_that("Continuous treatment", {
  skip_on_cran() #many tests, take too long
  skip_if_not_installed("rootSolve")
  skip_if_not_installed("cobalt")

  eps <- if (capabilities("long.double")) 1e-5 else 1e-1

  test_data <- readRDS(test_path("fixtures", "test_data.rds"))

  expect_no_condition({
    W0 <- weightit(Ac ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9,
                   data = test_data, method = "cbps",
                   include.obj = TRUE, solver = "optim")
  })

  sw.opts <- c(FALSE, TRUE)
  over.opts <- c("exact", "twostep", "cont")

  weight.mat <- matrix(nrow = nrow(test_data),
                       ncol = length(sw.opts) *
                         length(over.opts))
  colnames(weight.mat) <- rep("", ncol(weight.mat))

  k <- 1

  for (sw in sw.opts) {
    for (over in over.opts) {
      expect_no_error({
        suppressWarnings({
        W <- weightit(Ac ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9,
                      data = test_data, method = "cbps",
                      over = over != "exact", twostep = if (over == "exact") NULL else over == "twostep",
                      s.weights = if (sw) "SW" else NULL,
                      include.obj = TRUE, solver = "multiroot")
        })
      })

      n <- sprintf("W_%s_%s", sw, over)
      assign(n, W)

      if (over == "exact") {
        expect_equal(cobalt::col_w_cov(W$covs, W$treat, W$weights, std = TRUE,
                                       s.weights = W$s.weights),
                     0 * cobalt::col_w_cov(W$covs, W$treat, std = TRUE,
                                           s.weights = W$s.weights),
                     label = sprintf("A-X correlations for %s", n),
                     expected.label = "all 0s",
                     tolerance = eps)
      }

      expect_true(is_null((!!{{ str2lang(n) }})$ps))
      expect_false(is_null((!!{{ str2lang(n) }})$obj))

      for (i in seq_len(k - 1)) {
        expect_not_equal(W$weights, weight.mat[,i],
                         label = sprintf("Weights for %s", n),
                         expected.label = sprintf("weights for %s", colnames(weight.mat)[i]),
                         tolerance = min(1e-8, eps))
      }

      colnames(weight.mat)[k] <- n
      weight.mat[,k] <- W$weights
      k <- k + 1

      rm(list = n)
    }
  }

  #Non-full rank
  expect_no_condition({
    W <- weightit(Ac ~ X1 + X2 + X3 + X4 + X5 + X6 + X7 + X8 + X9 +
                    I(1 - X5) + I(X9 * 2),
                  data = test_data, method = "cbps",
                  include.obj = TRUE, solver = "optim")
  })

  expect_equal(W$weights, W0$weights, tolerance = eps)
})