testthat::test_that("bp works, ATE", { causalOT:::torch_check() testthat::skip_on_cran() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATE" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(x = original, estimand = estimand, method = "NNM") df <- data.frame(y = weights@data@y, z = weights@data@z, weights@data@x) bp <- barycentric_projection(formula = "y ~ .", data = df, separate.samples.on = "z", weights = weights) df0 <- df df1 <- df df0$z <- 0L df1$z <- 1L predictions0 <- predict(bp, newdata = df0, source.sample = df$z) predictions1 <- predict(bp, newdata = df1, source.sample = df$z) w <- rep(NA_real_, nrow(df0)) w[df$z == 1] <- weights@w1 w[df$z == 0] <- weights@w0 delta_bp <- predictions1 - predictions0 tau_bp <- sum(delta_bp * weights@data@weights) tau_est_sep <- estimate_effect(weights, model.function = barycentric_projection, estimate.separately = TRUE) tau_est_tgthr <- estimate_effect(weights, model.function = barycentric_projection, estimate.separately = FALSE) testthat::expect_equal(tau_est_tgthr@estimate, tau_est_sep@estimate) testthat::expect_equal(tau_bp, tau_est_sep@estimate) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_0, predictions0) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_1, predictions1) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_1 - tau_est_sep@augmentedData$y_hat_0, delta_bp) testthat::expect_equal(causalOT:::renormalize(w), causalOT:::renormalize(tau_est_sep@augmentedData$weights)) # augmented tau_aug <- estimate_effect(weights, model.function = barycentric_projection, augmented.model = TRUE) y <- weights@data@y z <- weights@data@z y0<- y[z==0] y1<- y[z==1] testthat::expect_equal(tau_aug@estimate, sum(weights@w1 * (y1 - tau_est_sep@augmentedData$y_hat_1[z==1])) - sum(weights@w0 * (y0 - tau_est_sep@augmentedData$y_hat_0[z==0])) + mean(tau_est_sep@augmentedData$y_hat_1 - tau_est_sep@augmentedData$y_hat_0), tol = 1e-5) }) testthat::test_that("bp works, ATT", { causalOT:::torch_check() testthat::skip_on_cran() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATT" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(x = original, estimand = estimand, method = "NNM") df <- data.frame(y = weights@data@y, z = weights@data@z, weights@data@x) bp <- barycentric_projection(formula = "y ~ .", data = df, separate.samples.on = "z", weights = weights) df0 <- df df1 <- df df0$z <- 0L df1$z <- 1L predictions0 <- predict(bp, newdata = df0, source.sample = df$z) predictions1 <- predict(bp, newdata = df1, source.sample = df$z) w <- rep(NA_real_, nrow(df0)) w[df$z == 1] <- weights@w1 w[df$z == 0] <- weights@w0 delta_bp <- predictions1 - predictions0 tau_bp <- sum(delta_bp[df$z==1] * weights@w1) tau_est_sep <- estimate_effect(weights, model.function = barycentric_projection, estimate.separately = TRUE) tau_est_tgthr <- estimate_effect(weights, model.function = barycentric_projection, estimate.separately = FALSE) testthat::expect_equal(tau_est_tgthr@estimate, tau_est_sep@estimate) testthat::expect_equal(tau_bp, tau_est_sep@estimate) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_0, predictions0) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_1, predictions1) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_1 - tau_est_sep@augmentedData$y_hat_0, delta_bp) testthat::expect_equal(causalOT:::renormalize(w), causalOT:::renormalize(tau_est_sep@augmentedData$weights)) }) testthat::test_that("bp works, ATC", { causalOT:::torch_check() testthat::skip_on_cran() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATC" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(x = original, estimand = estimand, method = "NNM") df <- data.frame(y = weights@data@y, z = weights@data@z, weights@data@x) bp <- barycentric_projection(formula = "y ~ .", data = df, separate.samples.on = "z", weights = weights) df0 <- df df1 <- df df0$z <- 0L df1$z <- 1L predictions0 <- predict(bp, newdata = df0, source.sample = df$z) predictions1 <- predict(bp, newdata = df1, source.sample = df$z) w <- rep(NA_real_, nrow(df0)) w[df$z == 1] <- weights@w1 w[df$z == 0] <- weights@w0 delta_bp <- predictions1 - predictions0 tau_bp <- sum(delta_bp[df$z==0] * weights@w0) tau_est_sep <- estimate_effect(weights, model.function = barycentric_projection, estimate.separately = TRUE) tau_est_tgthr <- estimate_effect(weights, model.function = barycentric_projection, estimate.separately = FALSE) testthat::expect_equal(tau_est_tgthr@estimate, tau_est_sep@estimate) testthat::expect_equal(tau_bp, tau_est_sep@estimate) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_0, predictions0) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_1, predictions1) testthat::expect_equal(tau_est_sep@augmentedData$y_hat_1 - tau_est_sep@augmentedData$y_hat_0, delta_bp) testthat::expect_equal(causalOT:::renormalize(w), causalOT:::renormalize(tau_est_sep@augmentedData$weights)) }) testthat::test_that("estimate effect works lm, ATT", { causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATT" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights, model.function = lm) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==0] <- w0 w[z==1] <- w1 w <- w/sum(w) form <- formula("y ~ .") environment(form) <- list2env(list(w0=w0, w1=w1, w = w), parent=environment(form)) fit0 <- lm(form, data = data.frame(x0, y = y0), weights = w0) fit1 <- lm(form, data = data.frame(x1, y = y1), weights = w1) pred1 <- predict(fit1, newdata = data.frame(x)) pred0 <- predict(fit0, newdata = data.frame(x)) delta <- pred1 - pred0 testthat::expect_equal(sum(delta[z==1] * w1), ee@estimate) testthat::expect_equal(ee@estimate, estimate_effect(weights, model.function = lm, estimate.separately = TRUE)@estimate) # augmented, separate ee2 <- estimate_effect(weights, model.function = lm, augment.estimate = TRUE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 form <- formula("y ~ .") environment(form) <- list2env(list(w0=w0, w1=w1), parent=environment(form)) fit0 <- lm(form, data = data.frame(x0, y = y0), weights = w0) fit1 <- lm(form, data = data.frame(x1, y = y1), weights = w1) pred1 <- predict(fit1, newdata = data.frame(x)) pred0 <- predict(fit0, newdata = data.frame(x)) delta <- pred1 - pred0 testthat::expect_equal(sum((y1 - pred0[z==1]) * w1) - sum((y0 - pred0[z==0]) * w0), ee2@estimate) testthat::expect_equal(ee2@estimate, estimate_effect(weights, model.function = lm, augment.estimate = TRUE, estimate.separately = TRUE)@estimate) # non-augmented, joint ee <- estimate_effect(weights, model.function = lm, estimate.separately = FALSE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==0] <- w0 w[z==1] <- w1 w <- w/sum(w) form <- formula("y ~ .") environment(form) <- list2env(list(w0=w0, w1=w1, w = w), parent=environment(form)) fit <- lm(form, data = data.frame(x, z = z, y = y), weights = w) pred1 <- predict(fit, newdata = data.frame(x, z = 1L)) pred0 <- predict(fit, newdata = data.frame(x, z = 0L)) delta <- pred1 - pred0 testthat::expect_equal(sum(delta[z==1] * w1), ee@estimate) # augmented, separate ee2 <- estimate_effect(weights, model.function = lm, estimate.separately = FALSE, augment.estimate = TRUE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 form <- formula("y ~ .") environment(form) <- list2env(list(w0=w0, w1=w1, w = w), parent=environment(form)) fit <- lm(form, data = data.frame(x, z = z, y = y), weights = w) pred1 <- predict(fit, newdata = data.frame(x, z = 1L)) pred0 <- predict(fit, newdata = data.frame(x, z = 0L)) delta <- pred1 - pred0 testthat::expect_equal(sum((y1 - pred0[z==1]) * w1) - sum((y0 - pred0[z==0]) * w0), ee2@estimate) }) testthat::test_that("estimate effect works lm, ATC", { causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATC" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights, model.function = lm) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, nrow(x)) w[z==1] <- w1 w[z==0] <- w0 w <- w/sum(w) form <- formula("y ~ .") environment(form) <- list2env(list(w0=w0, w1=w1, w = w), parent=environment(form)) fit0 <- lm(form, data = data.frame(x0, y = y0), weights = w0) fit1 <- lm(form, data = data.frame(x1, y = y1), weights = w1) pred1 <- predict(fit1, newdata = data.frame(x)) pred0 <- predict(fit0, newdata = data.frame(x)) delta <- pred1 - pred0 testthat::expect_equal(sum(delta[z==0] * w0), ee@estimate) testthat::expect_equal(ee@estimate, estimate_effect(weights, model.function = lm, estimate.separately = TRUE)@estimate) # augmented, separate ee2 <- estimate_effect(weights, model.function = lm, augment.estimate = TRUE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 fit0 <- lm(form, data = data.frame(x0, y = y0), weights = w0) fit1 <- lm(form, data = data.frame(x1, y = y1), weights = w1) pred1 <- predict(fit1, newdata = data.frame(x)) pred0 <- predict(fit0, newdata = data.frame(x)) delta <- pred1 - pred0 testthat::expect_equal(sum((y1 - pred1[z==1]) * w1) - sum((y0 - pred1[z==0]) * w0), ee2@estimate) testthat::expect_equal(ee2@estimate, estimate_effect(weights, model.function = lm, augment.estimate = TRUE, estimate.separately = TRUE)@estimate) # non-augmented, joint ee <- estimate_effect(weights, model.function = lm, estimate.separately = FALSE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==0] <- w0 w[z==1] <- w1 fit <- lm(form, data = data.frame(x, z = z, y = y), weights = w) pred1 <- predict(fit, newdata = data.frame(x, z = 1L)) pred0 <- predict(fit, newdata = data.frame(x, z = 0L)) delta <- pred1 - pred0 testthat::expect_equal(sum(delta[z==0] * w0), ee@estimate) # augmented, separate ee2 <- estimate_effect(weights, model.function = lm, estimate.separately = FALSE, augment.estimate = TRUE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 fit <- lm(form, data = data.frame(x, z = z, y = y), weights = w) pred1 <- predict(fit, newdata = data.frame(x, z = 1L)) pred0 <- predict(fit, newdata = data.frame(x, z = 0L)) delta <- pred1 - pred0 testthat::expect_equal(sum((y1 - pred0[z==1]) * w1) - sum((y0 - pred0[z==0]) * w0), ee2@estimate, tol = 1e-5) }) testthat::test_that("estimate effect works lm, ATE", { causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATE" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights, model.function = lm) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==1] <- w1 w[z==0] <- w0 w <- w/sum(w) form <- formula("y ~ .") environment(form) <- list2env(list(w0=w0, w1=w1, w = w), parent=environment(form)) fit0 <- lm(form, data = data.frame(x0, y = y0), weights = w0) fit1 <- lm(form, data = data.frame(x1, y = y1), weights = w1) pred1 <- predict(fit1, newdata = data.frame(x)) pred0 <- predict(fit0, newdata = data.frame(x)) delta <- pred1 - pred0 testthat::expect_equal(weighted.mean(delta, w = weights@data@weights), ee@estimate) testthat::expect_equal(ee@estimate, estimate_effect(weights, model.function = lm, estimate.separately = TRUE)@estimate) # augmented, separate ee2 <- estimate_effect(weights, model.function = lm, augment.estimate = TRUE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==1] <- w1 w[z==0] <- w0 w <- w/sum(w) fit0 <- lm(form, data = data.frame(x0, y = y0), weights = w0) fit1 <- lm(form, data = data.frame(x1, y = y1), weights = w1) pred1 <- predict(fit1, newdata = data.frame(x)) pred0 <- predict(fit0, newdata = data.frame(x)) delta <- pred1 - pred0 testthat::expect_equal(sum((y1 - pred1[z==1]) * w1) - sum((y0 - pred0[z==0]) * w0) + weighted.mean(delta, w = weights@data@weights), ee2@estimate) testthat::expect_equal(ee2@estimate, estimate_effect(weights, model.function = lm, augment.estimate = TRUE, estimate.separately = TRUE)@estimate) # non-augmented, joint ee <- estimate_effect(weights, model.function = lm, estimate.separately = FALSE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==0] <- w0 w[z==1] <- w1 fit <- lm(form, data = data.frame(x, z = z, y = y), weights = w) pred1 <- predict(fit, newdata = data.frame(x, z = 1L)) pred0 <- predict(fit, newdata = data.frame(x, z = 0L)) delta <- pred1 - pred0 testthat::expect_equal(sum(delta[z==0] * w0), ee@estimate) # augmented, separate ee2 <- estimate_effect(weights, model.function = lm, estimate.separately = FALSE, augment.estimate = TRUE) x <- weights@data@x z <- weights@data@z y <- weights@data@y x0 <- x[z==0,] x1 <- x[z==1,] y0 <- y[z==0] y1 <- y[z==1] w0 <- weights@w0 w1 <- weights@w1 w <- rep(NA_real_, length(z)) w[z==1] <- w1 w[z==0] <- w0 w <- w/sum(w) fit <- lm(form, data = data.frame(x, z = z, y = y), weights = w) pred1 <- predict(fit, newdata = data.frame(x, z = 1L)) pred0 <- predict(fit, newdata = data.frame(x, z = 0L)) delta <- pred1 - pred0 testthat::expect_equal(sum((y1 - pred1[z==1]) * w1) - sum((y0 - pred0[z==0]) * w0) + weighted.mean(delta, w = weights@data@weights), ee2@estimate) }) testthat::test_that("ATT give proper var",{ causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATT" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights) v <- vcov(ee) w0 <- weights@w0 w1 <- weights@w1 n1 <- length(w1) n0 <- length(w0) y <- weights@data@y z <- weights@data@z mu1 <- sum(y[z==1] * w1) mu0 <- sum(y[z==0] * w0) testthat::expect_equal(coef(ee), c(estimate = mu1-mu0)) v1 <- sum((w1 * n1 * (y[z==1] - mu1))^2)/(n1-1) v0 <- sum((w0 * n1 * (y[z==0] - mu0))^2)/(n1-1) testthat::expect_equal(v1, var(y[z==1]) ) testthat::expect_equal(v0/n1 + v1/n1, as.numeric(v)) }) testthat::test_that("ATT give proper var lm",{ causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATT" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights, model.function = lm, augment = TRUE) v <- vcov(ee) w0 <- weights@w0 w1 <- weights@w1 n1 <- length(w1) n0 <- length(w0) y <- weights@data@y z <- weights@data@z mu1 <- ee@augmentedData$y_hat_1 mu0 <- ee@augmentedData$y_hat_0 tau <- sum(w1 * (y - mu1)[z==1]) - sum(w0 * (y - mu0)[z==0]) + sum(w1 * (mu1 - mu0)[z==1]) testthat::expect_equal(coef(ee), c(estimate = tau)) v1 <- sum((w1 * n1 * (y - mu1)[z==1])^2)/(n1-1) v0 <- sum((w0 * n1 * (y - mu0)[z==0])^2)/(n1-1) vm <- sum(((mu1 - mu0 - coef(ee)) * z)^2)/(n1-1) testthat::expect_equal(v0/n1 + v1/n1 + vm/n1, as.numeric(v)) }) testthat::test_that("ATC give proper var",{ causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATC" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights) v <- vcov(ee) w0 <- weights@w0 w1 <- weights@w1 n1 <- length(w1) n0 <- length(w0) y <- weights@data@y z <- weights@data@z mu1 <- sum(y[z==1] * w1) mu0 <- sum(y[z==0] * w0) testthat::expect_equal(coef(ee), c(estimate = mu1-mu0)) v1 <- sum((w1 * n0 * (y[z==1] - mu1))^2)/(n0-1) v0 <- sum((w0 * n0 * (y[z==0] - mu0))^2)/(n0-1) testthat::expect_equal(v0, var(y[z==0]) ) testthat::expect_equal(v0/n0 + v1/n0, as.numeric(v)) }) testthat::test_that("ATC give proper var lm",{ causalOT:::torch_check() set.seed(9867) #### Load Packages #### library(causalOT) #### Sim param #### n <- 2^6 p <- 6 nsims <- 1 overlap <- "high" design <- "A" estimand <- "ATC" #### get simulation functions #### original <- Hainmueller$new(n = n, p = p, design = design, overlap = overlap) original$gen_data() weights <- calc_weight(original, estimand = estimand, method = "NNM") # non-augmented, separate ee <- estimate_effect(weights, model.function = lm, augment = TRUE) v <- vcov(ee) w0 <- weights@w0 w1 <- weights@w1 n1 <- length(w1) n0 <- length(w0) y <- weights@data@y z <- weights@data@z mu1 <- ee@augmentedData$y_hat_1 mu0 <- ee@augmentedData$y_hat_0 tau <- sum(w1 * (y - mu1)[z==1]) - sum(w0 * (y - mu0)[z==0]) + sum(w0 * (mu1 - mu0)[z==0]) testthat::expect_equal(coef(ee), c(estimate = tau)) v1 <- sum((w1 * n0 * (y - mu1)[z==1])^2)/(n0-1) v0 <- sum((w0 * n0 * (y - mu0)[z==0])^2)/(n0-1) vm <- sum(((mu1 - mu0 - coef(ee)) * (1-z))^2)/(n0-1) testthat::expect_equal(v0/n0 + v1/n0 + vm/n0, as.numeric(v)) })