tests/testthat/test_logit.R

In mattblackwell/DirectEffects: Estimating Controlled Direct Effects for Explaining Causal Findings

context("test_logit")

data("jobcorps")
jc <- jobcorps[
  1:100,
  c("treat", "female", "age_cat", "work2year2q", "pemplq4", "emplq4", "exhealth30")
]

test_that(
  "logit predicted values", {

    test_ipw <- cde_ipw()
    test_ipw <- set_treatment(test_ipw, treat, ~ female + age_cat)
    test_ipw <- treat_model(test_ipw, engine = "logit")
    test_ipw <- set_treatment(test_ipw, work2year2q, ~ pemplq4 + emplq4)
    test_ipw <- treat_model(test_ipw, engine = "logit")

    de_ipw_nocross <- estimate(test_ipw, exhealth30 ~ treat + work2year2q, jc, crossfit = FALSE)

    ipw_a1_mod <- glm(treat ~ female + age_cat, data = jc, family = binomial())
    ipw_a1_preds <- ipw_a1_mod$fitted
    expect_equivalent(ipw_a1_mod$fitted, de_ipw_nocross$model_fits[[1]]$treat_pred[, "1"])

    ipw_a2_mod_0 <- glm(work2year2q ~ female + age_cat + pemplq4 + emplq4,
                        data = jc, subset = treat == 0, family = binomial())
    ipw_a2_preds_0 <- predict(ipw_a2_mod_0, newdata = jc, type = "response")
    ipw_a2_mod_1 <- glm(work2year2q ~ female + age_cat + pemplq4 + emplq4,
                        data = jc, subset = treat == 1, family = binomial())
    ipw_a2_preds_1 <- predict(ipw_a2_mod_1, newdata = jc, type = "response")
    
    expect_equivalent(ipw_a2_preds_0, de_ipw_nocross$model_fits[[2]]$treat_pred[, "0_1"])
    expect_equivalent(ipw_a2_preds_1, de_ipw_nocross$model_fits[[2]]$treat_pred[, "1_1"])

    w_11 <- 1 / (ipw_a1_preds * ipw_a2_preds_1)
    w_10 <- 1 / (ipw_a1_preds * (1 - ipw_a2_preds_1))
    w_01 <- 1 / ((1 - ipw_a1_preds) * ipw_a2_preds_0)
    w_00 <- 1 / ((1 - ipw_a1_preds) * (1 - ipw_a2_preds_0))
    d_11 <- as.numeric(jc$treat == 1 & jc$work2year2q == 1)
    d_10 <- as.numeric(jc$treat == 1 & jc$work2year2q == 0)
    d_01 <- as.numeric(jc$treat == 0 & jc$work2year2q == 1)
    d_00 <- as.numeric(jc$treat == 0 & jc$work2year2q == 0) 
    w <- d_11 * w_11 + d_10 * w_10 + d_01 * w_01 + d_00 * w_00
    
    mu_11 <- sum(w_11 * d_11 * jc$exhealth30) / nrow(jc)
    mu_01 <- sum(w_01 * d_01 * jc$exhealth30) / nrow(jc)
    mu_10 <- sum(w_10 * d_10 * jc$exhealth30) / nrow(jc)
    mu_00 <- sum(w_00 * d_00 * jc$exhealth30) / nrow(jc)
    lm_out <- lm(exhealth30 ~ treat * work2year2q, data = jc, weights = w)
    
    expect_equal(
      unname(lm_out$coefficients[2]),
      de_ipw_nocross$estimates[1, "estimate"]
    )
    expect_equivalent(
      unname(lm_out$coefficients[2] + lm_out$coefficients[4]),
      de_ipw_nocross$estimates[2, "estimate"],
      tolerance = 1e-04
    )    
    expect_equivalent(
      unname(lm_out$coefficients[3]),
      de_ipw_nocross$estimates[3, "estimate"]
    )
    expect_equivalent(
      unname(lm_out$coefficients[3] + lm_out$coefficients[4]),
      de_ipw_nocross$estimates[4, "estimate"],
      tolerance = 1e-04
    )

})