clubSandwich/0000755000176200001440000000000014635072452012670 5ustar liggesusersclubSandwich/tests/0000755000176200001440000000000014634635343014035 5ustar liggesusersclubSandwich/tests/testthat/0000755000176200001440000000000014635072452015672 5ustar liggesusersclubSandwich/tests/testthat/test_plm-fixed-effects.R0000644000176200001440000003114214630154052022347 0ustar liggesuserscontext("plm objects - fixed effects") set.seed(20190513) skip_if_not_installed("plm") library(plm, quietly=TRUE) data("Produc", package = "plm") Produc$cluster <- sample(LETTERS[1:10], size = nrow(Produc), replace=TRUE) Produc_scramble <- Produc[sample(nrow(Produc)),] n <- nrow(Produc_scramble) plm_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc_scramble, index = c("state","year"), effect = "individual", model = "within") lm_individual <- lm(log(gsp) ~ 0 + state + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) individual_names <- names(coef(plm_individual)) individual_index <- names(coef(lm_individual)) %in% individual_names test_that("individual effects agree with lm", { expect_equal(vcovCR(plm_individual, type="CR0")[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR0")[individual_index,individual_index]) expect_equal(vcovCR(plm_individual, type="CR1")[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR1")[individual_index,individual_index]) expect_equal(vcovCR(plm_individual, type="CR2")[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR2")[individual_index,individual_index]) }) plm_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc_scramble, index = c("state","year"), effect = "time", model = "within") lm_time <- lm(log(gsp) ~ 0 + factor(year) + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) time_names <- names(coef(plm_time)) time_index <- names(coef(lm_time)) %in% time_names test_that("time effects agree with lm", { expect_equal(vcovCR(plm_time, type="CR0")[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR0")[time_index,time_index]) expect_equal(vcovCR(plm_time, type="CR1")[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR1")[time_index,time_index]) expect_equal(vcovCR(plm_time, type="CR2")[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR2")[time_index,time_index]) }) plm_twoways <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc_scramble, index = c("state","year"), effect = "twoways", model = "within") lm_twoways <- lm(log(gsp) ~ 0 + state + factor(year) + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) twoway_names <- names(coef(plm_twoways)) twoway_index <- names(coef(lm_twoways)) %in% twoway_names test_that("two-way effects agree with lm", { # clustering on individual expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR0")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR0")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR1")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR1")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR2")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR2")[twoway_index,twoway_index]) # clustering on time expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR0")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR0")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR1")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR1")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR2")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR2")[twoway_index,twoway_index]) # clustering on a randomly generated factor expect_equal(vcovCR(plm_twoways, cluster = Produc_scramble$cluster, type="CR0")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR0")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = Produc_scramble$cluster, type="CR1")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR1")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = Produc_scramble$cluster, type="CR2")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR2")[twoway_index,twoway_index]) }) test_that("bread works", { y <- plm_individual$model$"log(gsp)" expect_true(check_bread(plm_individual, cluster = findCluster.plm(plm_individual), y = y)) sigma_sq_ind <- with(plm_individual, sum(residuals^2) / df.residual) expect_equal(vcov(plm_individual), bread(plm_individual) * sigma_sq_ind / v_scale(plm_individual)) expect_true(check_bread(plm_time, cluster = findCluster.plm(plm_time), y = y)) sigma_sq_time <- with(plm_time, sum(residuals^2) / df.residual) expect_equal(vcov(plm_time), bread(plm_time) * sigma_sq_time / v_scale(plm_time)) expect_true(check_bread(plm_twoways, cluster = Produc_scramble$state, y = y)) expect_true(check_bread(plm_twoways, cluster = Produc_scramble$year, y = y)) sigma_sq_two <- with(plm_twoways, sum(residuals^2) / df.residual) expect_equal(vcov(plm_twoways), bread(plm_twoways) * sigma_sq_two / v_scale(plm_twoways)) }) test_that("CR0 and CR1S agree with arellano vcov", { expect_equal(vcovHC(plm_individual, method="arellano", type = "HC0", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_individual, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR1S")), check.attributes = FALSE) expect_equal(vcovHC(plm_time, method="arellano", type = "HC0", cluster = "time"), as.matrix(vcovCR(plm_time, type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_time, method="arellano", type = "sss", cluster = "time"), as.matrix(vcovCR(plm_time, type = "CR1S")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "HC0", cluster = "group"), as.matrix(vcovCR(plm_twoways, cluster = "individual", type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_twoways, cluster = "individual", type = "CR1S")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "HC0", cluster = "time"), as.matrix(vcovCR(plm_twoways, cluster = "time", type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "sss", cluster = "time"), as.matrix(vcovCR(plm_twoways, cluster = "time", type = "CR1S")), check.attributes = FALSE) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(plm_individual, type = "CR2") expect_equal(vcovCR(plm_individual, cluster = Produc_scramble$state, type = "CR2"), CR2_iv) expect_equal(vcovCR(plm_individual, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(plm_individual, type = "CR2", target = rep(1, n), inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(plm_individual, type = "CR2", inverse_var = FALSE) expect_equivalent(CR2_not, CR2_iv) expect_equal(vcovCR(plm_individual, cluster = Produc_scramble$state, type = "CR2", inverse_var = FALSE), CR2_not) expect_equal(vcovCR(plm_individual, type = "CR2", target = rep(1, n)), CR2_not) expect_equal(vcovCR(plm_individual, type = "CR2", target = rep(1, n), inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(plm_individual, type = "CR2", target = 1 / Produc_scramble$emp), CR2_not)) }) test_that("vcovCR options work for CR4", { CR4_iv <- vcovCR(plm_individual, type = "CR4") expect_equal(vcovCR(plm_individual, cluster = Produc_scramble$state, type = "CR4"), CR4_iv) expect_equal(vcovCR(plm_individual, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(plm_individual, type = "CR4", target = rep(1, n), inverse_var = TRUE), CR4_iv) CR4_not <- vcovCR(plm_individual, type = "CR4", inverse_var = FALSE) expect_equivalent(CR4_not, CR4_iv) expect_equal(vcovCR(plm_individual, cluster = Produc_scramble$state, type = "CR4", inverse_var = FALSE), CR4_not) expect_equal(vcovCR(plm_individual, type = "CR4", target = rep(1, n)), CR4_not) expect_equal(vcovCR(plm_individual, type = "CR4", target = rep(1, n), inverse_var = FALSE), CR4_not) expect_false(identical(vcovCR(plm_individual, type = "CR4", target = 1 / Produc_scramble$emp), CR4_not)) }) test_that("CR2 and CR4 are target-unbiased", { skip_on_cran() expect_true(check_CR(plm_individual, vcov = "CR2")) expect_true(check_CR(plm_individual, vcov = "CR4")) expect_true(check_CR(plm_individual, vcov = "CR2", inverse_var = FALSE)) expect_true(check_CR(plm_individual, vcov = "CR4", inverse_var = FALSE)) expect_true(check_CR(plm_time, vcov = "CR2")) expect_true(check_CR(plm_time, vcov = "CR4")) expect_true(check_CR(plm_time, vcov = "CR2", inverse_var = FALSE)) expect_true(check_CR(plm_time, vcov = "CR4", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "individual")) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "individual")) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "individual", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "individual", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "time")) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "time")) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "time", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "time", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = Produc_scramble$cluster)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = Produc_scramble$cluster)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = Produc_scramble$cluster, inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = Produc_scramble$cluster, inverse_var = FALSE)) }) test_that("vcovCR is equivalent to vcovHC when clusters are all of size 1", { library(sandwich, quietly=TRUE) CR_types <- paste0("CR",c(0,2)) HC_types <- paste0("HC",c(0,2)) CR_individual <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_individual, cluster = 1:n, type = t))) HC_individual <- lapply(HC_types, function(t) vcovHC(lm_individual, type = t)[individual_index,individual_index]) expect_equal(CR_individual, HC_individual) CR_time <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_time, cluster = 1:n, type = t))) HC_time <- lapply(HC_types, function(t) vcovHC(lm_time, type = t)[time_index,time_index]) expect_equal(CR_time, HC_time) CR_twoways <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_twoways, cluster = 1:n, type = t))) HC_twoways <- lapply(HC_types, function(t) vcovHC(lm_twoways, type = t)[twoway_index,twoway_index]) expect_equal(CR_twoways, HC_twoways) }) test_that("CR2 is equivalent to Welch t-test for DiD design", { m0 <- 4 m1 <- 9 m <- m0 + m1 cluster <- factor(rep(LETTERS[1:m], each = 2)) n <- length(cluster) time <- rep(c(1,2), m) trt_clusters <- c(rep(0,m0), rep(1,m1)) trt <- (time - 1) * rep(trt_clusters, each = 2) nu <- rnorm(m)[cluster] e <- rnorm(n) y <- 0.4 * trt + nu + e dat <- data.frame(y, time, trt, cluster) plm_DID <- plm(y ~ trt, data = dat, index = c("cluster","time"), effect = "twoways", model = "within") plm_Satt <- coef_test(plm_DID, vcov = "CR2", cluster = dat$cluster)["trt",] plm_Wald <- Wald_test(plm_DID, constraints = constrain_zero(1), vcov = "CR2", cluster = dat$cluster) df <- m^2 * (m0 - 1) * (m1 - 1) / (m0^2 * (m0 - 1) + m1^2 * (m1 - 1)) y_diff <- apply(matrix(y, nrow = 2), 2, diff) t_Welch <- t.test(y_diff ~ trt_clusters) expect_equal(with(t_Welch, estimate[[2]] - estimate[[1]]), plm_Satt$beta) expect_equal(as.numeric(-t_Welch$statistic), with(plm_Satt, beta / SE)) expect_equal(as.numeric(-t_Welch$statistic)^2, plm_Wald$Fstat) expect_is(all.equal(as.numeric(t_Welch$parameter), plm_Satt$df_Satt), "character") expect_equal(plm_Satt$df, df) expect_equal(plm_Wald$df_denom, df) }) clubSandwich/tests/testthat/test_impute_covariance_matrix.R0000644000176200001440000003633114630154052024133 0ustar liggesuserscontext("impute_covariance_matrix") set.seed(20190513) K <- 20 N <- sum(1:K) dat <- data.frame( study = rep(LETTERS[1:K], 1:K), yi = rnorm(N), vi = rchisq(N, df = 2), ti = sample(1:(10 * N), N), si = sample(letters[1:3], N, replace = TRUE) ) dat$v_study <- unsplit(tapply(dat$vi, dat$study, mean), dat$study) dat_scramble <- dat[sample.int(nrow(dat)),] test_that("impute_covariance_matrix error messages and missing argument handling are correct.", { expect_error(impute_covariance_matrix(vi = dat$vi, cluster = dat$study)) expect_error(impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ti = dat$ti)) expect_error(impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ar1 = 0.8)) V1 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6) V2 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, ti = dat$ti) V3 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, ti = dat$ti, ar1 = 0) V4 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ti = dat$ti, ar1 = 0.5) V5 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.0, ti = dat$ti, ar1 = 0.5) expect_equal(V1, V2) expect_equal(V1, V3) expect_equal(V4, V5) }) test_that("impute_covariance_matrix returns correct correlations.", { r <- 0.7 V_single_r <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = r) r_list <- rbeta(K, 2, 2) V_multiple_r <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = r_list) check_correlation <- function(M, r) if (nrow(M) > 1) max(abs(cov2cor(M)[lower.tri(M)] - r)) else 0 check_singles <- sapply(V_single_r, check_correlation, r = r) expect_true(all(check_singles < 10^-14)) check_multiples <- Map(check_correlation, M = V_multiple_r, r = r_list) expect_true(all(check_multiples < 10^-14)) dat_scramble <- dat[sample(nrow(dat)),] V_mat <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = r) expect_equal(dat_scramble$vi, diag(V_mat)) V_resorted <- V_mat[order(dat_scramble$study), order(dat_scramble$study)] dat_unscramble <- dat_scramble[order(dat_scramble$study),] V_unscramble <- impute_covariance_matrix(vi = dat_unscramble$vi, cluster = dat_unscramble$study, r = r) expect_equal(V_resorted, unblock(V_unscramble)) }) test_that("impute_covariance_matrix works with AR1 argument.", { ar1 <- 0.5 V_mat <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ti = 1:nrow(dat), ar1 = ar1) r_mat <- lapply(V_mat, cov2cor) r_sums <- sapply(r_mat, sum) check <- sapply(2:K, function(k) k + 2 * sum((1:(k-1)) * ar1^((k-1):1))) expect_equal(r_sums[-1], check, check.attributes = FALSE) V_mat_big <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ti = 1:nrow(dat), ar1 = ar1, return_list = FALSE) r_mat_big <- cov2cor(V_mat_big) expect_equal(sum(r_mat_big), sum(check) + 1) v_sums <- sapply(V_mat, sum) expect_equal(sum(v_sums), sum(V_mat_big)) }) test_that("impute_covariance_matrix works with subgroup argument.", { X <- model.matrix(~ si + 0, data = dat) X_list <- by(X, dat$study, as.matrix) check_diag <- function(v, x) { XVX <- t(x) %*% v %*% x all.equal(sum(XVX), sum(diag(XVX))) } check_all_diag <- function(v_list,x_list) { all(mapply(check_diag , v = v_list, x = x_list)) } V1 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, subgroup = dat$si) V2 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, ti = dat$ti, subgroup = dat$si) V3 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, ti = dat$ti, ar1 = 0, subgroup = dat$si) V4 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ti = dat$ti, ar1 = 0.5, subgroup = dat$si) V5 <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.0, ti = dat$ti, ar1 = 0.5, subgroup = dat$si) expect_true(check_all_diag(V1, X_list)) expect_true(check_all_diag(V2, X_list)) expect_true(check_all_diag(V3, X_list)) expect_true(check_all_diag(V4, X_list)) expect_true(check_all_diag(V5, X_list)) X_scramble <- model.matrix(~ si + 0, data = dat_scramble) V1 <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.6, subgroup = dat_scramble$si) V2 <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.6, ti = dat_scramble$ti, subgroup = dat_scramble$si) V3 <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.6, ti = dat_scramble$ti, ar1 = 0, subgroup = dat_scramble$si) V4 <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, ti = dat_scramble$ti, ar1 = 0.5, subgroup = dat_scramble$si) V5 <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.0, ti = dat_scramble$ti, ar1 = 0.5, subgroup = dat_scramble$si) expect_true(check_diag(V1, X_scramble)) expect_true(check_diag(V2, X_scramble)) expect_true(check_diag(V3, X_scramble)) expect_true(check_diag(V4, X_scramble)) expect_true(check_diag(V5, X_scramble)) }) test_that("impute_covariance_matrix works with smooth argument.", { V1 <- impute_covariance_matrix(vi = dat$v_study, cluster = dat$study, r = 0.6) V2 <- impute_covariance_matrix(vi = dat$v_study, cluster = dat$study, r = 0.6, ti = dat$ti) V3 <- impute_covariance_matrix(vi = dat$v_study, cluster = dat$study, r = 0.6, ti = dat$ti, ar1 = 0) V4 <- impute_covariance_matrix(vi = dat$v_study, cluster = dat$study, ti = dat$ti, ar1 = 0.5) V5 <- impute_covariance_matrix(vi = dat$v_study, cluster = dat$study, r = 0.0, ti = dat$ti, ar1 = 0.5) V1s <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, smooth_vi = TRUE) V2s <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, ti = dat$ti, smooth_vi = TRUE) V3s <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.6, ti = dat$ti, ar1 = 0, smooth_vi = TRUE) V4s <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, ti = dat$ti, ar1 = 0.5, smooth_vi = TRUE) V5s <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = 0.0, ti = dat$ti, ar1 = 0.5, smooth_vi = TRUE) expect_equal(V1, V1s) expect_equal(V2, V2s) expect_equal(V3, V3s) expect_equal(V4, V4s) expect_equal(V5, V5s) V1 <- impute_covariance_matrix(vi = dat_scramble$v_study, cluster = dat_scramble$study, r = 0.6) V2 <- impute_covariance_matrix(vi = dat_scramble$v_study, cluster = dat_scramble$study, r = 0.6, ti = dat_scramble$ti) V3 <- impute_covariance_matrix(vi = dat_scramble$v_study, cluster = dat_scramble$study, r = 0.6, ti = dat_scramble$ti, ar1 = 0) V4 <- impute_covariance_matrix(vi = dat_scramble$v_study, cluster = dat_scramble$study, ti = dat_scramble$ti, ar1 = 0.5) V5 <- impute_covariance_matrix(vi = dat_scramble$v_study, cluster = dat_scramble$study, r = 0.0, ti = dat_scramble$ti, ar1 = 0.5) V1s <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.6, smooth_vi = TRUE) V2s <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.6, ti = dat_scramble$ti, smooth_vi = TRUE) V3s <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.6, ti = dat_scramble$ti, ar1 = 0, smooth_vi = TRUE) V4s <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, ti = dat_scramble$ti, ar1 = 0.5, smooth_vi = TRUE) V5s <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = 0.0, ti = dat_scramble$ti, ar1 = 0.5, smooth_vi = TRUE) expect_equal(V1, V1s) expect_equal(V2, V2s) expect_equal(V3, V3s) expect_equal(V4, V4s) expect_equal(V5, V5s) }) test_that("impute_covariance_matrix works with unobserved factors.", { K <- 10 N <- sum(1:K) dat <- data.frame(study = rep(LETTERS[1:K], 1:K), yi = rnorm(N), vi = rchisq(N, df = 2)) levels(dat$study) <- LETTERS[1:(K + 3)] r <- 0.7 V_single_r <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = r) r_list <- rbeta(K, 2, 2) V_multiple_r <- impute_covariance_matrix(vi = dat$vi, cluster = dat$study, r = r_list) check_correlation <- function(M, r) if (nrow(M) > 1) max(abs(cov2cor(M)[lower.tri(M)] - r)) else 0 check_singles <- sapply(V_single_r, check_correlation, r = r) expect_true(all(check_singles < 10^-14)) dat_scramble <- dat[sample(nrow(dat)),] V_mat <- impute_covariance_matrix(vi = dat_scramble$vi, cluster = dat_scramble$study, r = r) expect_equal(dat_scramble$vi, diag(V_mat)) V_resorted <- V_mat[order(dat_scramble$study), order(dat_scramble$study)] dat_unscramble <- dat_scramble[order(dat_scramble$study),] V_unscramble <- impute_covariance_matrix(vi = dat_unscramble$vi, cluster = dat_unscramble$study, r = r) expect_equal(V_resorted, unblock(V_unscramble)) }) test_that("impute_covariance_matrix works with missing variances.", { skip_if_not_installed("robumeta") data(corrdat, package = "robumeta") dat_miss <- corrdat dat_miss$var[sample.int(nrow(corrdat), size = round(nrow(corrdat) / 10))] <- NA V_missing <- impute_covariance_matrix(dat_miss$var, cluster = dat_miss$studyid, r = 0.8, return_list = FALSE) non_missing_rows <- !is.na(dat_miss$var) V_missing <- V_missing[non_missing_rows, non_missing_rows] dat_complete <- subset(dat_miss, !is.na(var)) V_complete <- impute_covariance_matrix(dat_complete$var, cluster = dat_complete$studyid, r = 0.8, return_list = FALSE) expect_equal(V_missing, V_complete) }) test_that("pattern_covariance_matrix works.", { skip_if_not_installed("robumeta") skip_if_not_installed("metafor") data(oswald2013, package = "robumeta") dat <- metafor::escalc(data = oswald2013, measure = "ZCOR", ri = R, ni = N) # make a patterned correlation matrix p_levels <- levels(dat$Crit.Cat) r_pattern <- 0.7^as.matrix(dist(1:length(p_levels))) diag(r_pattern) <- seq(0.75, 0.95, length.out = 6) rownames(r_pattern) <- colnames(r_pattern) <- p_levels # impute the covariance matrix using patterned correlations V_list <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern, smooth_vi = TRUE) r_pattern1 <- r_pattern2 <- r_pattern # Recreate a constant covariance matrix r_pattern1[1:6,1:6] <- 0.6 V_pattern_const <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern1, smooth_vi = FALSE) V_impute_const <- impute_covariance_matrix(vi = dat$vi, cluster = dat$Study, r = 0.6) expect_equal(V_pattern_const, V_impute_const, check.attributes = FALSE) # Patterns work with excluded categories exclude <- 3:5 r_pattern2[3:5,] <- 0.3 r_pattern2[,3:5] <- 0.3 V_pattern_exclude <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern[-(3:5),-(3:5)], r = 0.3, smooth_vi = FALSE) V_pattern_full <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern2, smooth_vi = FALSE) expect_equal(V_pattern_exclude, V_pattern_full) # Patterns work with extra categories levs <- c(p_levels, LETTERS[1:5]) r_pattern3 <- matrix(-4, nrow = length(levs), ncol = length(levs), dimnames = list(levs, levs)) r_pattern3[p_levels,p_levels] <- r_pattern[p_levels, p_levels] V_pattern_extra <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern3, r = 0.3, smooth_vi = TRUE) expect_equal(V_pattern_extra, V_list) V_pattern_extra_exclude <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern3[-(3:5),-(3:5)], r = 0.3, smooth_vi = FALSE) expect_equal(V_pattern_extra_exclude, V_pattern_full) VS_pattern_extra_exclude <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern3[-(3:5),-(3:5)], r = 0.3, subgroup = dat$IAT.Focus, smooth_vi = FALSE, return_list = FALSE) VS_pattern_full <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern2, subgroup = dat$IAT.Focus, smooth_vi = FALSE, return_list = FALSE) expect_equal(VS_pattern_extra_exclude, VS_pattern_full) expect_warning( pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern3[-(3:5),-(3:5)], r = 4, subgroup = dat$IAT.Focus, smooth_vi = FALSE, return_list = FALSE) ) V_npd <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern3[-(3:5),-(3:5)], r = 4, subgroup = dat$IAT.Focus, smooth_vi = FALSE, return_list = FALSE, check = FALSE) expect_true(inherits(V_npd, "matrix")) # pattern_covariance_matrix works with missing entries dat_miss <- dat dat_miss$vi[sample.int(nrow(dat), size = round(nrow(dat) / 10))] <- NA V_missing <- pattern_covariance_matrix(dat_miss$vi, cluster = dat_miss$Study, pattern_level = dat_miss$Crit.Cat, r_pattern = r_pattern, return_list = FALSE) non_missing_rows <- !is.na(dat_miss$vi) V_missing <- V_missing[non_missing_rows, non_missing_rows] dat_complete <- subset(dat_miss, !is.na(vi)) V_complete <- pattern_covariance_matrix(dat_complete$vi, cluster = dat_complete$Study, pattern_level = dat_complete$Crit.Cat, r_pattern = r_pattern, return_list = FALSE) expect_equal(V_missing, V_complete) dat_miss$Crit.Cat[sample.int(nrow(dat), size = round(nrow(dat) / 10))] <- NA expect_error( pattern_covariance_matrix(dat_miss$vi, cluster = dat_miss$Study, pattern_level = dat_miss$Crit.Cat, r_pattern = r_pattern, return_list = TRUE, check_PD = FALSE) ) }) clubSandwich/tests/testthat/test_AER_ivreg.R0000644000176200001440000002452314630154052020655 0ustar liggesuserscontext("AER::ivreg objects") set.seed(20190513) skip_if_not_installed("zoo") skip_if_not_installed("AER") library(zoo, quietly=TRUE) library(AER, quietly=TRUE) data("CigarettesSW", package = "AER") Cigs <- within(CigarettesSW, { rprice <- price/cpi rincome <- income/population/cpi tdiff <- (taxs - tax)/cpi }) CR_types <- paste0("CR",0:4) obj_un <- ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs) obj_wt <- ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, weights = population) X <- model.matrix(obj_wt, component = "regressors") Z <- model.matrix(obj_wt, component = "instruments") y <- log(CigarettesSW$packs) w <- weights(obj_wt) test_that("Basic calculations from ivreg agree for unweighted model.", { XZ <- model.matrix(obj_un, component = "projected") ZtZ_inv <- chol2inv(chol(t(Z) %*% Z)) XZ_check <- Z %*% ZtZ_inv %*% t(Z) %*% X expect_equal(XZ, XZ_check, check.attributes=FALSE) expect_equal(coef(obj_un), lm.fit(XZ, y)$coefficients) expect_equal (bread(obj_un), chol2inv(chol(t(XZ) %*% XZ)) * nobs(obj_un), check.attributes=FALSE) hii <- diag(X %*% chol2inv(chol(t(XZ) %*% XZ)) %*% t(XZ)) expect_equal(hatvalues(obj_un), hii) r <- as.vector(y - X %*% coef(obj_un)) expect_equal(r, as.vector(residuals_CS(obj_un))) }) test_that("Basic calculations from ivreg agree for weighted model.", { XZ <- model.matrix(obj_wt, component = "projected") ZwZ_inv <- chol2inv(chol(t(Z) %*% (w * Z))) XZ_check <- Z %*% ZwZ_inv %*% t(Z) %*% (w * X) expect_equal(XZ, XZ_check, check.attributes=FALSE) expect_equal(coef(obj_wt), lm.wfit(XZ, y, w)$coefficients) expect_equal(bread(obj_wt), chol2inv(chol(t(XZ) %*% (w * XZ))) * nobs(obj_wt), check.attributes=FALSE) hii <- diag(X%*% chol2inv(chol(t(XZ) %*% (w * XZ))) %*% t(w * XZ)) expect_false(all(hatvalues(obj_wt) == hii)) # does not agree because hatvalues doesn't work with weighting r <- as.vector(y - X %*% coef(obj_wt)) expect_equal(r, as.vector(residuals_CS(obj_wt))) }) test_that("bread works", { expect_true(check_bread(obj_un, cluster = Cigs$state, y = log(Cigs$packs))) tsls_vcov <- bread(obj_un) * summary(obj_un)$sigma^2 / v_scale(obj_un) expect_equal(vcov(obj_un), tsls_vcov) expect_true(check_bread(obj_wt, cluster = Cigs$state, y = log(Cigs$packs))) wtsls_vcov <- bread(obj_wt) * summary(obj_wt)$sigma^2 / v_scale(obj_wt) expect_equal(vcov(obj_wt), wtsls_vcov) }) test_that("vcovCR options don't matter for CR0", { expect_error(vcovCR(obj_un, type = "CR0")) CR0 <- vcovCR(obj_un, cluster = Cigs$state, type = "CR0") expect_output(print(CR0)) attr(CR0, "target") <- NULL attr(CR0, "inverse_var") <- NULL CR0_A <- vcovCR(obj_un, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population) attr(CR0_A, "target") <- NULL attr(CR0_A, "inverse_var") <- NULL expect_identical(CR0_A, CR0) CR0_B <- vcovCR(obj_un, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = FALSE) attr(CR0_B, "target") <- NULL attr(CR0_B, "inverse_var") <- NULL expect_identical(CR0_A, CR0) expect_error(vcovCR(obj_un, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = TRUE)) wCR0 <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR0") attr(wCR0, "target") <- NULL attr(wCR0, "inverse_var") <- NULL wCR0_A <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population) attr(wCR0_A, "target") <- NULL attr(wCR0_A, "inverse_var") <- NULL expect_identical(wCR0_A, wCR0) wCR0_B <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = FALSE) attr(wCR0_B, "target") <- NULL attr(wCR0_B, "inverse_var") <- NULL expect_identical(wCR0_B, wCR0) expect_error(vcovCR(obj_wt, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = TRUE)) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(obj_un, cluster = Cigs$state, type = "CR2") expect_equal(vcovCR(obj_un, cluster = Cigs$state, type = "CR2", target = rep(1, nobs(obj_un))), CR2_iv) expect_false(identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR2", target = 1 / Cigs$population), CR2_iv)) wCR2_id <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR2") expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR2", inverse_var = FALSE), wCR2_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR2", target = rep(1, nobs(obj_un))), wCR2_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR2", target = rep(1, nobs(obj_un)), inverse_var = FALSE), wCR2_id) }) test_that("vcovCR options work for CR4", { CR4_not <- vcovCR(obj_un, cluster = Cigs$state, type = "CR4") expect_identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_un))), CR4_not) expect_identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_un)), inverse_var = FALSE), CR4_not) expect_false(identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR4", target = 1 / Cigs$population), CR4_not)) wCR4_id <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR4") expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR4", inverse_var = FALSE), wCR4_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_wt))), wCR4_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_wt)), inverse_var = FALSE), wCR4_id) }) test_that("CR2 is target-unbiased", { expect_true(check_CR(obj_un, vcov = "CR2", cluster = Cigs$state)) expect_true(check_CR(obj_wt, vcov = "CR2", cluster = Cigs$state)) }) test_that("CR4 is target-unbiased", { skip("Need to understand target-unbiasedness for ivreg objects.") expect_true(check_CR(obj_un, vcov = "CR4", cluster = Cigs$state)) expect_true(check_CR(obj_wt, vcov = "CR4", cluster = Cigs$state)) }) test_that("vcovCR is equivalent to vcovHC (with HC0 or HC1) when clusters are all of size 1", { library(sandwich, quietly=TRUE) CR0 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR0") expect_equal(vcovHC(obj_un, type = "HC0"), as.matrix(CR0)) CR1 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR1S") expect_equal(vcovHC(obj_un, type = "HC1"), as.matrix(CR1)) CR2 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR2") expect_false(all(vcovHC(obj_un, type = "HC2") == as.matrix(CR2))) CR3 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR3") expect_false(all(vcovHC(obj_un, type = "HC3") == as.matrix(CR3))) }) test_that("Order doesn't matter.",{ check_sort_order(obj_wt, Cigs, "state") }) test_that("clubSandwich works with dropped observations", { dat_miss <- Cigs dat_miss$rincome[sample.int(nrow(Cigs), size = round(nrow(Cigs) / 10))] <- NA iv_dropped <- update(obj_un, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(rincome)) iv_complete <- update(obj_un, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(iv_dropped, cluster = dat_miss$state, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(iv_complete, cluster = dat_complete$state, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(iv_dropped, vcov = x, cluster = dat_miss$state, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(iv_complete, vcov = x, cluster = dat_complete$state, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("weight scale doesn't matter", { iv_fit_w <- update(obj_un, weights = rep(4, nobs(obj_un))) unweighted_fit <- lapply(CR_types, function(x) vcovCR(obj_un, cluster = Cigs$state, type = x)) weighted_fit <- lapply(CR_types, function(x) vcovCR(iv_fit_w, cluster = Cigs$state, type = x)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix), tol = 5 * 10^-7) target <- 1 + rpois(nrow(Cigs), lambda = 8) unweighted_fit <- lapply(CR_types, function(x) vcovCR(obj_un, cluster = Cigs$state, type = x, target = target)) weighted_fit <- lapply(CR_types, function(x) vcovCR(iv_fit_w, cluster = Cigs$state, type = x, target = target * 15)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix), tol = 5 * 10^-7) }) test_that("clubSandwich works with weights of zero.", { n_Cigs <- nrow(Cigs) Cigs$awt <- rpois(n_Cigs, lambda = 1.4) table(Cigs$awt) iv_full <- update(obj_un, weights = awt) Cigs_sub <- subset(Cigs, awt > 0) iv_sub <- update(iv_full, data = Cigs_sub) CR_full <- lapply(CR_types, function(x) vcovCR(iv_full, cluster = Cigs$state, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(iv_sub, cluster = Cigs_sub$state, type = x)) expect_equal(CR_full, CR_sub, check.attributes = FALSE) test_full <- lapply(CR_types, function(x) coef_test(iv_full, vcov = x, cluster = Cigs$state, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) test_sub <- lapply(CR_types, function(x) coef_test(iv_sub, vcov = x, cluster = Cigs_sub$state, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) expect_equal(test_full, test_sub, check.attributes = FALSE) dat_miss <- Cigs miss_indicator <- sample.int(n_Cigs, size = round(n_Cigs / 10)) dat_miss$rincome[miss_indicator] <- NA with(dat_miss, table(awt, is.na(rincome))) iv_dropped <- update(iv_full, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(rincome)) iv_complete <- update(iv_full, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(iv_dropped, cluster = dat_miss$state, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(iv_complete, cluster = dat_complete$state, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(iv_dropped, vcov = x, cluster = dat_miss$state, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(iv_complete, vcov = x, cluster = dat_complete$state, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) clubSandwich/tests/testthat/test_glm_logit.R0000644000176200001440000002457514630154052021036 0ustar liggesuserscontext("logit glm objects") set.seed(20190513) m <- 20 cluster <- factor(rep(LETTERS[1:m], 3 + rpois(m, 5))) n <- length(cluster) X1 <- c(rep(-0.5, m / 2), rep(0.5, m / 2))[cluster] X2 <- c(rep(-0.3, 0.4 * m), rep(0.7, 0.3 * m), rep(-0.3, 0.4 * m))[cluster] X3 <- rnorm(m)[cluster] + rnorm(n) X4 <- rnorm(n) X <- cbind(X1, X2, X3, X4) eta <- -0.4 + X %*% c(0.3, -0.6, 0.15, 0.15) p <- 1 / (1 + exp(-eta)) summary(p) w <- sample(1:4, size = n, replace = TRUE) y1 <- rbinom(n, size = 1, prob = p) y2 <- rbinom(n, size = w, prob = p) yp <- y2 / w dat <- data.frame(y1, y2, yp, X, cluster, w, row = 1:n) logit_fit <- glm(y1 ~ X1 + X2 + X3 + X4, data = dat, family = "binomial") sflogit_fit <- glm(cbind(y2, w - y2) ~ X1 + X2 + X3 + X4, data = dat, family = "binomial") plogit_fit <- glm(yp ~ X1 + X2 + X3 + X4, data = dat, weights = w, family = "quasibinomial") # obj <- logit_fit # y <- dat$y1 # type <- "CR2" # vcov <- vcovCR(obj, cluster = cluster, type = type) # target = NULL # inverse_var = FALSE # # cluster <- droplevels(as.factor(cluster)) # B <- sandwich::bread(obj) / v_scale(obj) # X_list <- matrix_list(model_matrix(obj), cluster, "row") # W_list <- weightMatrix(obj, cluster) # XWX <- Reduce("+", Map(function(x, w) t(x) %*% w %*% x, x = X_list, w = W_list)) # M <- chol2inv(chol(XWX)) # attr(M, "dimnames") <- attr(B, "dimnames") # # M / B # diff(range(M / B)) test_that("bread works", { expect_true(check_bread(logit_fit, cluster = dat$cluster, check_coef = FALSE, tol = 1.5 * 10^-3)) glm_vcov <- bread(logit_fit) * summary(logit_fit)$dispersion / v_scale(logit_fit) expect_equal(vcov(logit_fit), glm_vcov) expect_true(check_bread(sflogit_fit, cluster = dat$cluster, check_coef = FALSE, tol = 1.5 * 10^-3)) glm_vcov <- bread(sflogit_fit) * summary(sflogit_fit)$dispersion / v_scale(sflogit_fit) expect_equal(vcov(sflogit_fit), glm_vcov) expect_true(check_bread(plogit_fit, cluster = dat$cluster, check_coef = FALSE, tol = 1.5 * 10^-3)) glm_vcov <- bread(plogit_fit) * summary(plogit_fit)$dispersion / v_scale(plogit_fit) expect_equal(vcov(plogit_fit), glm_vcov) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(logit_fit, cluster = dat$cluster, type = "CR2") expect_equal(vcovCR(logit_fit, cluster = dat$cluster, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(logit_fit, cluster = dat$cluster, type = "CR2", target = targetVariance(logit_fit, cluster = dat$cluster), inverse_var = TRUE), CR2_iv) attr(CR2_iv, "inverse_var") <- FALSE expect_equal(vcovCR(logit_fit, cluster = dat$cluster, type = "CR2", target = targetVariance(logit_fit, cluster = dat$cluster), inverse_var = FALSE), CR2_iv) CR2_iv <- vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR2") expect_equal(vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR2", target = targetVariance(sflogit_fit, cluster = dat$cluster), inverse_var = TRUE), CR2_iv) attr(CR2_iv, "inverse_var") <- FALSE expect_equal(vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR2", target = targetVariance(sflogit_fit, cluster = dat$cluster), inverse_var = FALSE), CR2_iv) CR2_iv <- vcovCR(plogit_fit, cluster = dat$cluster, type = "CR2") expect_equal(vcovCR(plogit_fit, cluster = dat$cluster, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(plogit_fit, cluster = dat$cluster, type = "CR2", target = targetVariance(plogit_fit, cluster = dat$cluster), inverse_var = TRUE), CR2_iv) attr(CR2_iv, "inverse_var") <- FALSE expect_equal(vcovCR(plogit_fit, cluster = dat$cluster, type = "CR2", target = targetVariance(plogit_fit, cluster = dat$cluster), inverse_var = FALSE), CR2_iv) }) test_that("vcovCR options work for CR4", { CR4_iv <- vcovCR(logit_fit, cluster = dat$cluster, type = "CR4") expect_equal(vcovCR(logit_fit, cluster = dat$cluster, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(logit_fit, cluster = dat$cluster, type = "CR4", target = targetVariance(logit_fit, cluster = dat$cluster), inverse_var = TRUE), CR4_iv) attr(CR4_iv, "inverse_var") <- FALSE expect_equal(vcovCR(logit_fit, cluster = dat$cluster, type = "CR4", target = targetVariance(logit_fit, cluster = dat$cluster), inverse_var = FALSE), CR4_iv) CR4_iv <- vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR4") expect_equal(vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR4", target = targetVariance(sflogit_fit, cluster = dat$cluster), inverse_var = TRUE), CR4_iv) attr(CR4_iv, "inverse_var") <- FALSE expect_equal(vcovCR(sflogit_fit, cluster = dat$cluster, type = "CR4", target = targetVariance(sflogit_fit, cluster = dat$cluster), inverse_var = FALSE), CR4_iv) CR4_iv <- vcovCR(plogit_fit, cluster = dat$cluster, type = "CR4") expect_equal(vcovCR(plogit_fit, cluster = dat$cluster, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(plogit_fit, cluster = dat$cluster, type = "CR4", target = targetVariance(plogit_fit, cluster = dat$cluster), inverse_var = TRUE), CR4_iv) attr(CR4_iv, "inverse_var") <- FALSE expect_equal(vcovCR(plogit_fit, cluster = dat$cluster, type = "CR4", target = targetVariance(plogit_fit, cluster = dat$cluster), inverse_var = FALSE), CR4_iv) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(logit_fit, vcov = "CR2", cluster = dat$cluster)) expect_true(check_CR(sflogit_fit, vcov = "CR2", cluster = dat$cluster)) expect_true(check_CR(plogit_fit, vcov = "CR2", cluster = dat$cluster)) expect_true(check_CR(logit_fit, vcov = "CR4", cluster = dat$cluster)) expect_true(check_CR(sflogit_fit, vcov = "CR4", cluster = dat$cluster)) expect_true(check_CR(plogit_fit, vcov = "CR4", cluster = dat$cluster)) }) test_that("vcovCR is equivalent to vcovHC when clusters are all of size 1", { library(sandwich, quietly=TRUE) HC_types <- paste0("HC", 0:3) HC_list <- lapply(HC_types, function(t) vcovHC(logit_fit, type = t)) CR_types <- paste0("CR", 0:3) CR_types[2] <- "CR1S" CR_list <- lapply(CR_types, function(t) as.matrix(vcovCR(logit_fit, cluster = dat$row, type = t))) expect_equal(HC_list, CR_list, tol = 4 * 10^-4) }) CR_types <- paste0("CR", 0:4) test_that("Order doesn't matter.",{ check_sort_order(logit_fit, dat = dat, cluster = "cluster") }) test_that("clubSandwich works with dropped observations", { dat_miss <- dat dat_miss$X1[sample.int(n, size = round(n / 10))] <- NA logit_dropped <- update(logit_fit, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(X1)) logit_complete <- update(logit_fit, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(logit_dropped, cluster = dat_miss$cluster, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(logit_complete, cluster = dat_complete$cluster, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(logit_dropped, vcov = x, cluster = dat_miss$cluster, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(logit_complete, vcov = x, cluster = dat_complete$cluster, test = "All", p_values = FALSE)) compare_ttests(test_drop, test_complete) }) test_that("clubSandwich works with aliased predictors", { data(npk, package = "datasets") npk_alias <- glm(yield ~ block + N*P*K, data = npk) npk_drop <- glm(yield ~ block + N + P + K + N:P + N:K + P:K, data = npk) CR_alias <- lapply(CR_types[-4], function(x) vcovCR(npk_alias, cluster = npk$block, type = x)) CR_drop <- lapply(CR_types[-4], function(x) vcovCR(npk_drop, cluster = npk$block, type = x)) expect_equal(CR_alias, CR_drop) test_drop <- lapply(CR_types[-4], function(x) coef_test(npk_alias, vcov = x, cluster = npk$block, test = c("z","naive-t","Satterthwaite"), coefs = 7:12, p_values = FALSE)) test_complete <- lapply(CR_types[-4], function(x) coef_test(npk_drop, vcov = x, cluster = npk$block, test = c("z","naive-t","Satterthwaite"), coefs = 7:12, p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("clubSandwich results are equivalent to geepack", { skip_if_not_installed("geepack") library(geepack) # check CR0 with logit logit_gee <- geeglm(y1 ~ X1 + X2 + X3 + X4, id = cluster, data = dat, family = "binomial") logit_refit <- update(logit_fit, start = coef(logit_gee)) expect_equal(coef(logit_refit), coef(logit_gee)) V_gee0 <- summary(logit_gee)$cov.scaled V_CR0 <- as.matrix(vcovCR(logit_refit, cluster = dat$cluster, type = "CR0")) attr(V_gee0, "dimnames") <- attr(V_CR0, "dimnames") expect_equal(V_gee0, V_CR0) # check CR3 with logit logit_gee <- geeglm(y1 ~ X1 + X2 + X3 + X4, id = cluster, data = dat, family = "binomial", std.err = "jack") V_gee3 <- summary(logit_gee)$cov.scaled V_CR3 <- as.matrix(vcovCR(logit_refit, cluster = dat$cluster, type = "CR3")) attr(V_gee3, "dimnames") <- attr(V_CR3, "dimnames") expect_equal(V_gee3 * m / (m - 6), V_CR3) # check CR0 with plogit plogit_gee <- geeglm(yp ~ X1 + X2 + X3 + X4, id = cluster, data = dat, weights = w, family = "binomial") plogit_refit <- update(plogit_fit, start = coef(plogit_gee)) expect_equal(coef(plogit_refit), coef(plogit_gee)) V_gee0 <- summary(plogit_gee)$cov.scaled V_CR0 <- as.matrix(vcovCR(plogit_refit, cluster = dat$cluster, type = "CR0")) attr(V_gee0, "dimnames") <- attr(V_CR0, "dimnames") expect_equal(V_gee0, V_CR0) }) clubSandwich/tests/testthat/test_lmerMod.R0000644000176200001440000002545514630154052020456 0ustar liggesuserscontext("lmerMod objects") set.seed(20191217) skip_if_not_installed("lme4") skip_if_not_installed("nlme") skip_if_not_installed("mlmRev") suppressMessages(library(lme4, quietly=TRUE)) library(nlme, quietly=TRUE, warn.conflicts=FALSE) obj_A1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) obj_A2 <- lmer(Reaction ~ Days + (Days || Subject), sleepstudy) data(Orthodont, package="nlme") obj_B1 <- lmer(distance ~ age + (1 | Subject), data=Orthodont) obj_B2 <- lmer(distance ~ age + (age || Subject), data=Orthodont) data(egsingle, package = "mlmRev") egsingle <- within(egsingle, { size <- (size - mean(size)) / sd(size) }) obj_C1 <- lmer(math ~ year * size + female + black + hispanic + (1 | schoolid) + (1 | childid), data = egsingle) obj_C2 <- lmer(math ~ year * size + female + black + hispanic + (year | schoolid) + (1 | childid), data = egsingle, control = lmerControl(check.conv.grad = .makeCC("ignore", tol = 2e-3, relTol = NULL))) test_that("bread works", { expect_true(check_bread(obj_A1, cluster = sleepstudy$Subject, y = sleepstudy$Reaction)) expect_true(check_bread(obj_A2, cluster = sleepstudy$Subject, y = sleepstudy$Reaction)) expect_true(check_bread(obj_B1, cluster = Orthodont$Subject, y = Orthodont$distance)) expect_true(check_bread(obj_B2, cluster = Orthodont$Subject, y = Orthodont$distance)) expect_true(check_bread(obj_C1, cluster = egsingle$schoolid, y = egsingle$math)) expect_true(check_bread(obj_C2, cluster = egsingle$schoolid, y = egsingle$math)) expect_equal(as.matrix(vcov(obj_A1)), bread(obj_A1) * getME(obj_A1, "sigma")^2 / v_scale(obj_A1)) expect_equal(as.matrix(vcov(obj_A2)), bread(obj_A2) * getME(obj_A2, "sigma")^2 / v_scale(obj_A2)) expect_equal(as.matrix(vcov(obj_B1)), bread(obj_B1) * getME(obj_B1, "sigma")^2 / v_scale(obj_B1)) expect_equal(as.matrix(vcov(obj_B2)), bread(obj_B2) * getME(obj_B2, "sigma")^2 / v_scale(obj_B2)) expect_equal(as.matrix(vcov(obj_C1)), bread(obj_C1) * getME(obj_C1, "sigma")^2 / v_scale(obj_C1)) expect_equal(as.matrix(vcov(obj_C2)), bread(obj_C2) * getME(obj_C2, "sigma")^2 / v_scale(obj_C2)) }) test_that("vcovCR options work for CR2", { CR2_A <- vcovCR(obj_A1, type = "CR2") expect_equal(vcovCR(obj_A1, cluster = sleepstudy$Subject, type = "CR2"), CR2_A) expect_equal(vcovCR(obj_A1, type = "CR2", inverse_var = TRUE), CR2_A) expect_false(identical(vcovCR(obj_A1, type = "CR2", inverse_var = FALSE), CR2_A)) target <- targetVariance(obj_A1) expect_equal(vcovCR(obj_A1, type = "CR2", target = target, inverse_var = TRUE), CR2_A, check.attributes = FALSE) expect_equal(vcovCR(obj_A1, type = "CR2", target = target, inverse_var = FALSE), CR2_A, check.attributes = FALSE) CR2_B <- vcovCR(obj_B1, type = "CR2") expect_equal(vcovCR(obj_B1, cluster = Orthodont$Subject, type = "CR2"), CR2_B) expect_equal(vcovCR(obj_B1, type = "CR2", inverse_var = TRUE), CR2_B) expect_false(identical(vcovCR(obj_B1, type = "CR2", inverse_var = FALSE), CR2_B)) target <- targetVariance(obj_B1) expect_equal(vcovCR(obj_B1, type = "CR2", target = target, inverse_var = TRUE), CR2_B, check.attributes = FALSE) expect_equal(vcovCR(obj_B1, type = "CR2", target = target, inverse_var = FALSE), CR2_B, check.attributes = FALSE) CR2_C <- vcovCR(obj_C1, type = "CR2") expect_equal(vcovCR(obj_C1, cluster = egsingle$schoolid, type = "CR2"), CR2_C) expect_equal(vcovCR(obj_C1, type = "CR2", inverse_var = TRUE), CR2_C) expect_false(identical(vcovCR(obj_C1, type = "CR2", inverse_var = FALSE), CR2_C)) target <- targetVariance(obj_C1) expect_equal(vcovCR(obj_C1, type = "CR2", target = target, inverse_var = TRUE), CR2_C, check.attributes = FALSE) expect_equal(vcovCR(obj_C1, type = "CR2", target = target, inverse_var = FALSE), CR2_C, check.attributes = FALSE) }) test_that("vcovCR options work for CR4", { CR4_A <- vcovCR(obj_A1, type = "CR4") expect_equal(vcovCR(obj_A1, cluster = sleepstudy$Subject, type = "CR4"), CR4_A) expect_equal(vcovCR(obj_A1, type = "CR4", inverse_var = TRUE), CR4_A) expect_false(identical(vcovCR(obj_A1, type = "CR4", inverse_var = FALSE), CR4_A)) target <- targetVariance(obj_A1) expect_equal(vcovCR(obj_A1, type = "CR4", target = target, inverse_var = TRUE), CR4_A, check.attributes = FALSE) expect_equal(vcovCR(obj_A1, type = "CR4", target = target, inverse_var = FALSE), CR4_A, check.attributes = FALSE) CR4_B <- vcovCR(obj_B1, type = "CR4") expect_equal(vcovCR(obj_B1, cluster = Orthodont$Subject, type = "CR4"), CR4_B) expect_equal(vcovCR(obj_B1, type = "CR4", inverse_var = TRUE), CR4_B) expect_false(identical(vcovCR(obj_B1, type = "CR4", inverse_var = FALSE), CR4_B)) target <- targetVariance(obj_B1) expect_equal(vcovCR(obj_B1, type = "CR4", target = target, inverse_var = TRUE), CR4_B, check.attributes = FALSE) expect_equal(vcovCR(obj_B1, type = "CR4", target = target, inverse_var = FALSE), CR4_B, check.attributes = FALSE) CR4_C <- vcovCR(obj_C1, type = "CR4") expect_equal(vcovCR(obj_C1, cluster = egsingle$schoolid, type = "CR4"), CR4_C) expect_equal(vcovCR(obj_C1, type = "CR4", inverse_var = TRUE), CR4_C) expect_false(identical(vcovCR(obj_C1, type = "CR4", inverse_var = FALSE), CR4_C)) target <- targetVariance(obj_C1) expect_equal(vcovCR(obj_C1, type = "CR4", target = target, inverse_var = TRUE), CR4_C, check.attributes = FALSE) expect_equal(vcovCR(obj_C1, type = "CR4", target = target, inverse_var = FALSE), CR4_C, check.attributes = FALSE) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(obj_A1, vcov = "CR2")) expect_true(check_CR(obj_A2, vcov = "CR2")) expect_true(check_CR(obj_B1, vcov = "CR2")) expect_true(check_CR(obj_B2, vcov = "CR2")) expect_true(check_CR(obj_C1, vcov = "CR2")) expect_true(check_CR(obj_C2, vcov = "CR2")) expect_true(check_CR(obj_A1, vcov = "CR4")) expect_true(check_CR(obj_A2, vcov = "CR4")) expect_true(check_CR(obj_B1, vcov = "CR4")) expect_true(check_CR(obj_B2, vcov = "CR4")) expect_true(check_CR(obj_C1, vcov = "CR4")) expect_true(check_CR(obj_C2, vcov = "CR4")) }) CR_types <- paste0("CR",0:4) test_that("Order doesn't matter.", { skip_on_cran() # Model A1 check_sort_order(obj = obj_A1, dat = sleepstudy) # Model C1 check_sort_order(obj = obj_C1, dat = egsingle) }) test_that("clubSandwich works with dropped observations", { dat_miss <- sleepstudy dat_miss$Reaction[sample.int(nrow(sleepstudy), size = round(nrow(sleepstudy) / 10))] <- NA obj_dropped <- update(obj_A1, data = dat_miss, na.action = na.omit) obj_complete <- update(obj_A1, data = dat_miss, subset = !is.na(Reaction)) CR_drop <- lapply(CR_types, function(x) vcovCR(obj_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(obj_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(obj_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(obj_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("lmer agrees with lme", { data(BodyWeight, package="nlme") lmer_fit <- lmer(weight ~ Time * Diet + (1 | Rat), data=BodyWeight) lme_fit <- lme(weight ~ Time * Diet, data=BodyWeight, ~ 1 | Rat) expect_equal(coef_CS(lmer_fit), coef_CS(lme_fit)) expect_equal(nobs(lmer_fit), nobs(lme_fit)) expect_equal(model_matrix(lmer_fit), model_matrix(lme_fit), check.attributes = FALSE) expect_equal(residuals_CS(lmer_fit), residuals_CS(lme_fit), check.attributes = FALSE) expect_equal(v_scale(lmer_fit), v_scale(lme_fit)) p <- length(coef_CS(lmer_fit)) expect_equal(bread(lmer_fit) / bread(lme_fit), matrix(1, p, p), check.attributes = FALSE, tol = 10^-6) expect_equal(targetVariance(lmer_fit), targetVariance(lme_fit), check.attributes = FALSE, tol = 10^-6) expect_equal(weightMatrix(lmer_fit), weightMatrix(lme_fit), check.attributes = FALSE, tol = 10^-6) CR_lmer <- lapply(CR_types, function(x) vcovCR(lmer_fit, type = x)) CR_lme <- lapply(CR_types, function(x) vcovCR(lme_fit, type = x)) expect_equivalent(CR_lmer, CR_lme, tolerance = 10^-6) test_lmer <- lapply(CR_types, function(x) coef_test(lmer_fit, vcov = x, test = "All", p_values = FALSE)) test_lme <- lapply(CR_types, function(x) coef_test(lme_fit, vcov = x, test = "All", p_values = FALSE)) compare_ttests(test_lmer, test_lme, tol = 10^-10) constraints <- c(combn(length(coef_CS(lmer_fit)), 2, simplify = FALSE), combn(length(coef_CS(lmer_fit)), 3, simplify = FALSE)) Wald_lmer <- Wald_test(lmer_fit, constraints = constrain_zero(constraints), vcov = "CR2", test = "All") Wald_lme <- Wald_test(lme_fit, constraints = constrain_zero(constraints), vcov = "CR2", test = "All") compare_Waldtests(Wald_lmer, Wald_lme) }) test_that("Emply levels are dropped in model_matrix", { data(AchievementAwardsRCT) AA_RCT_females <- subset(AchievementAwardsRCT, sex=="Girl" & year != "1999") AA_RCT_females <- within(AA_RCT_females, { sibs_4 <- siblings >= 4 treated2001 <- treated * (year=="2001") }) lmer_fit <- lmer(Bagrut_status ~ year * school_type + father_ed + mother_ed + immigrant + sibs_4 + qrtl + treated2001:half + (1 | school_id), data = AA_RCT_females) betas <- fixef(lmer_fit) X <- model_matrix(lmer_fit) expect_identical(names(betas), colnames(X)) }) test_that("Possible to cluster at higher level than random effects", { n_districts <- 10 n_schools_per <- rnbinom(n_districts, size = 4, prob = 0.3) n_schools <- sum(n_schools_per) n_students_per <- 10 n_students <- n_schools * n_students_per # identifiers for each level district_id <- factor(rep(1:n_districts, n_schools_per * n_students_per)) school_id <- factor(rep(1:sum(n_schools_per), each = n_students_per)) student_id <- 1:n_students # simulated outcome Y <- rnorm(n_districts)[district_id] + rnorm(n_schools)[school_id] + rnorm(n_students) X <- rnorm(n_students) dat <- data.frame(district_id, school_id, student_id, Y, X) dat_scramble <- dat[sample(nrow(dat)),] # fit two-level model lme_2level <- lmer(Y ~ X + (1 | school_id), data = dat) # cluster at level 3 V <- vcovCR(lme_2level, type = "CR2", cluster = dat$district_id) expect_is(V, "vcovCR") expect_error(vcovCR(lme_2level, type = "CR2", cluster = dat_scramble$district_id)) # check that result does not depend on sort-order V_scramble <- vcovCR(lmer(Y ~ X + (1 | school_id), data = dat_scramble), type = "CR2", cluster = dat_scramble$district_id) expect_equal(as.matrix(V), as.matrix(V_scramble)) }) clubSandwich/tests/testthat/test_plm-first-differences.R0000644000176200001440000001240214630154052023233 0ustar liggesuserscontext("plm objects - first differences model") set.seed(20190513) skip_if_not_installed("plm") skip_if_not_installed("AER") library(plm, quietly=TRUE) data(Fatalities, package = "AER") Fatalities <- within(Fatalities, { frate <- 10000 * fatal / pop drinkagec <- cut(drinkage, breaks = 18:22, include.lowest = TRUE, right = FALSE) drinkagec <- relevel(drinkagec, ref = 4) }) plm_FD <- plm(frate ~ beertax + drinkagec + miles + unemp + log(income), data = Fatalities, index = c("state", "year"), model = "fd") n_obs <- nobs(plm_FD) target <- with(Fatalities, 1 / pop[year != levels(year)[1]]) test_that("bread works", { y <- na.omit(diff(plm_FD$model$frate)) cluster <- findCluster.plm(plm_FD) expect_true(check_bread(plm_FD, cluster = cluster, y = y)) sigma_sq <- with(plm_FD, sum(residuals^2) / df.residual) expect_equal(vcov(plm_FD), bread(plm_FD) * sigma_sq / v_scale(plm_FD)) }) test_that("CR0 and CR1S agree with arellano vcov", { expect_equal(vcovHC(plm_FD, method="arellano", type = "HC0", cluster = "group"), as.matrix(vcovCR(plm_FD, type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_FD, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_FD, type = "CR1S")), check.attributes = FALSE) }) test_that("CR0 and CR1S agree with arellano vcov for versions <= 2.6-1", { skip_if(packageVersion("plm") > "2.6-1") X <- model_matrix(plm_FD) e <- residuals(plm_FD) index <- attr(model.frame(plm_FD), "index") cluster <- index[[2]] cluster <- cluster[index[[2]] != levels(index[[2]])[1]] estmats <- sapply(split.data.frame(e * X, cluster, drop = TRUE), colSums) meat <- tcrossprod(estmats) bread <- chol2inv(chol(crossprod(X))) vcov_time <- bread %*% meat %*% bread attr(vcov_time, "dimnames") <- attr(meat, "dimnames") expect_equal(vcov_time, as.matrix(vcovCR(plm_FD, cluster = "time", type = "CR0"))) baloney <- tcrossprod(estmats[,-6]) vcov_baloney <- bread %*% baloney %*% bread attr(vcov_baloney, "dimnames") <- attr(baloney, "dimnames") expect_equal(vcov_baloney, vcovHC(plm_FD, method="arellano", type = "HC0", cluster = "time"), check.attributes = FALSE) }) test_that("CR0 and CR1S agree with arellano vcov for versions > 2.6-1", { skip_if_not_installed("plm", minimum_version = "2.6-2") expect_equal(vcovHC(plm_FD, method="arellano", type = "HC0", cluster = "time"), as.matrix(vcovCR(plm_FD, type = "CR0", cluster = "time")), check.attributes = FALSE) expect_equal(vcovHC(plm_FD, method="arellano", type = "sss", cluster = "time"), as.matrix(vcovCR(plm_FD, type = "CR1S", cluster = "time")), check.attributes = FALSE) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(plm_FD, type = "CR2") expect_equal(vcovCR(plm_FD, cluster = Fatalities$state, type = "CR2"), CR2_iv) expect_equal(vcovCR(plm_FD, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(plm_FD, type = "CR2", target = rep(1, n_obs), inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(plm_FD, type = "CR2", inverse_var = FALSE) expect_equivalent(CR2_not, CR2_iv) expect_equal(vcovCR(plm_FD, cluster = Fatalities$state, type = "CR2", inverse_var = FALSE), CR2_not) expect_equal(vcovCR(plm_FD, type = "CR2", target = rep(1, n_obs)), CR2_not) expect_equal(vcovCR(plm_FD, type = "CR2", target = rep(1, n_obs), inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(plm_FD, type = "CR2", target = target), CR2_not)) }) test_that("vcovCR options work for CR4", { skip_on_cran() CR4_iv <- vcovCR(plm_FD, type = "CR4") expect_equal(vcovCR(plm_FD, cluster = Fatalities$state, type = "CR4"), CR4_iv) expect_equal(vcovCR(plm_FD, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(plm_FD, type = "CR4", target = rep(1, n_obs), inverse_var = TRUE), CR4_iv) CR4_not <- vcovCR(plm_FD, type = "CR4", inverse_var = FALSE) expect_equivalent(CR4_not, CR4_iv, tolerance = 10^-3) expect_equal(vcovCR(plm_FD, cluster = Fatalities$state, type = "CR4", inverse_var = FALSE), CR4_not) expect_equal(vcovCR(plm_FD, type = "CR4", target = rep(1, n_obs)), CR4_not) expect_equal(vcovCR(plm_FD, type = "CR4", target = rep(1, n_obs), inverse_var = FALSE), CR4_not) expect_false(identical(vcovCR(plm_FD, type = "CR4", target = target), CR4_not)) }) test_that("CR2 is target-unbiased", { expect_true(check_CR(plm_FD, vcov = "CR2", tol = 10^-7)) expect_true(check_CR(plm_FD, vcov = "CR2", inverse_var = FALSE)) expect_true(check_CR(plm_FD, cluster = "time", vcov = "CR2", tol = 10^-7)) expect_true(check_CR(plm_FD, cluster = "time", vcov = "CR2", inverse_var = FALSE)) }) test_that("vcovCR is equivalent to vcovHC when clusters are all of size 1", { CR_types <- paste0("CR",c(0,2)) HC_types <- paste0("HC",c(0,2)) CR_individual <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_FD, cluster = 1:nrow(Fatalities), type = t))) HC_individual <- lapply(HC_types, function(t) vcovHC(plm_FD, method = "white1", type = t)) expect_equal(CR_individual, HC_individual, check.attributes = FALSE) }) clubSandwich/tests/testthat/test_mlm.R0000644000176200001440000002576014630154052017643 0ustar liggesuserscontext("mlm objects") set.seed(20190513) n <- nrow(iris) lm_fit <- lm(cbind(Sepal.Length, Sepal.Width) ~ Species + Petal.Length, data = iris) lm_A_fit <- lm(Sepal.Length ~ Species + Petal.Length, data = iris) lm_B_fit <- lm(Sepal.Width ~ Species + Petal.Length, data = iris) WLS_fit <- lm(cbind(Sepal.Length, Sepal.Width) ~ Species + Petal.Length, data = iris, weights = Petal.Width) CR_types <- paste0("CR",0:4) test_that("bread works", { expect_equal(bread.mlm(lm_fit), sandwich:::bread.mlm(lm_fit)) y <- with(iris, as.vector(rbind(Sepal.Length, Sepal.Width))) cluster <- rep(rownames(iris), each = ncol(residuals(lm_fit))) expect_true(check_bread(lm_fit, cluster = cluster, y = y)) expect_true(check_bread(WLS_fit, cluster = cluster, y = y)) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(lm_fit, vcov = "CR2")) expect_true(check_CR(WLS_fit, vcov = "CR2")) expect_true(check_CR(lm_fit, vcov = "CR4")) expect_true(check_CR(WLS_fit, vcov = "CR4")) }) test_that("vcovCR is mostly equivalent to vcovHC when clusters are all of size 1", { library(sandwich, quietly=TRUE) CR_mats <- sapply(c("CR0","CR2","CR3","CR1","CR1p","CR1S"), function(t) as.matrix(vcovCR(lm_fit, type = t)), simplify = FALSE, USE.NAMES = TRUE) HC_mats <- sapply(c("HC0","HC2","HC3","HC1"), function(t) vcovHC(lm_fit, type = t), simplify = FALSE, USE.NAMES = TRUE) expect_equal(CR_mats$CR0, HC_mats$HC0) expect_equal(CR_mats$CR2, HC_mats$HC2) expect_equal(CR_mats$CR3, HC_mats$HC3) J <- nobs(lm_fit) p <- ncol(model.matrix(lm_fit)) N <- nrow(model_matrix(lm_fit)) expect_equal(CR_mats$CR1 * (J - 1), HC_mats$HC1 * (J - p)) expect_equal(CR_mats$CR1p * (J - 2 * p), HC_mats$HC1 * (J - p)) expect_equal(CR_mats$CR1S * (J - 1) * (N - 2 * p) / (N - 1), HC_mats$HC1 * (J - p)) HC_A_mats <- sapply(c("HC0","HC2","HC3"), function(t) vcovHC(lm_A_fit, type = t), simplify = FALSE, USE.NAMES = TRUE) HC_B_mats <- sapply(c("HC0","HC2","HC3"), function(t) vcovHC(lm_B_fit, type = t), simplify = FALSE, USE.NAMES = TRUE) expect_equal(CR_mats$CR0[1:p,1:p], HC_A_mats$HC0, check.attributes = FALSE) expect_equal(CR_mats$CR2[1:p,1:p], HC_A_mats$HC2, check.attributes = FALSE) expect_equal(CR_mats$CR3[1:p,1:p], HC_A_mats$HC3, check.attributes = FALSE) expect_equal(CR_mats$CR0[p + 1:p,p + 1:p], HC_B_mats$HC0, check.attributes = FALSE) expect_equal(CR_mats$CR2[p + 1:p,p + 1:p], HC_B_mats$HC2, check.attributes = FALSE) expect_equal(CR_mats$CR3[p + 1:p,p + 1:p], HC_B_mats$HC3, check.attributes = FALSE) }) test_that("mlm is equivalent to lm with long data.", { iris_long <- reshape(iris, c("Sepal.Length","Sepal.Width"), direction = "long", times = "outcome") iris_long$outcome <- paste0("Sepal.", iris_long$time) lm_long <- lm(Sepal ~ 0 + outcome + outcome:Species + outcome:Petal.Length, data = iris_long) i <- order(rep(1:2, 4)) expect_equal(coef_CS(lm_fit), coef(lm_long)[i], check.attributes = FALSE) CR_fit <- lapply(CR_types, function(x) as.matrix(vcovCR(lm_fit, type = x))) CR_long <- lapply(CR_types, function(x) vcovCR(lm_long, type = x, cluster = iris_long$id)[i,i]) expect_equivalent(CR_fit, CR_long) test_fit <- lapply(CR_types, function(x) coef_test(lm_fit, vcov = x, test = "All", p_values = FALSE)) test_long <- lapply(CR_types, function(x) coef_test(lm_long, vcov = x, cluster = iris_long$id, test = "All", p_values = FALSE)[i,]) compare_ttests(test_fit, test_long) CR_fit <- lapply(CR_types, function(x) as.matrix(vcovCR(lm_fit, type = x, cluster = iris$Petal.Length))) CR_long <- lapply(CR_types, function(x) vcovCR(lm_long, type = x, cluster = iris_long$Petal.Length)[i,i]) expect_equivalent(CR_fit, CR_long) test_fit <- lapply(CR_types, function(x) coef_test(lm_fit, vcov = x, test = "All", p_values = FALSE)) test_long <- lapply(CR_types, function(x) coef_test(lm_long, vcov = x, cluster = iris_long$id, test = "All", p_values = FALSE)[i,]) compare_ttests(test_fit, test_long) }) test_that("Order doesn't matter.",{ skip_on_cran() check_sort_order(WLS_fit, iris) }) test_that("clubSandwich works with dropped covariates", { dat_miss <- iris dat_miss$Petal.Length[sample.int(n, size = round(n / 10))] <- NA lm_dropped <- update(lm_fit, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(Petal.Length)) lm_complete <- update(lm_fit, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("clubSandwich works with dropped outcomes", { dat_miss <- iris n <- nrow(dat_miss) dat_miss$Sepal.Length[sample.int(n, size = round(n / 10))] <- NA dat_miss$Sepal.Width[sample.int(n, size = round(n / 10))] <- NA lm_dropped <- update(lm_fit, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(Sepal.Length) & !is.na(Sepal.Width)) lm_complete <- update(lm_fit, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, test = "All", p_values = FALSE)) compare_ttests(test_drop, test_complete) }) test_that("clubSandwich works with dropped outcomes, covariates, and weights", { dat_miss <- iris n <- nrow(dat_miss) dat_miss$Sepal.Length[sample.int(n, size = round(n / 5))] <- NA dat_miss$Sepal.Width[sample.int(n, size = round(n / 5))] <- NA dat_miss$Petal.Length[sample.int(n, size = round(n / 5))] <- NA dat_miss$Petal.Width[sample.int(n, size = round(n / 5))] <- NA WLS_dropped <- update(WLS_fit, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(Petal.Length) & !is.na(Petal.Width) & !is.na(Sepal.Length) & !is.na(Sepal.Width)) WLS_complete <- update(WLS_fit, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(WLS_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(WLS_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(WLS_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(WLS_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("weight scale doesn't matter", { lm_fit_w <- update(lm_fit, weights = rep(10, nrow(iris))) unweighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit, type = x)) weighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit_w, type = x)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix)) target <- rep(1 + rpois(nrow(iris), lambda = 8), each = ncol(residuals(lm_fit))) unweighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit, type = x, target = target)) weighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit_w, type = x, target = target * 15)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix)) }) test_that("clubSandwich works with weights of zero.", { data("LifeCycleSavings", package = "datasets") n_life <- nrow(LifeCycleSavings) LifeCycleSavings$cl <- substr(rownames(LifeCycleSavings), 1, 1) table(LifeCycleSavings$cl) LifeCycleSavings$wt <- rpois(nrow(LifeCycleSavings), lambda = 0.8) table(LifeCycleSavings$wt) lm_full <- lm(cbind(dpi, ddpi) ~ pop15 + pop75 + sr, data = LifeCycleSavings, weights = wt) LCS_sub <- subset(LifeCycleSavings, wt > 0) lm_sub <- lm(cbind(dpi, ddpi) ~ pop15 + pop75 + sr, data = LCS_sub, weights = wt) CR_full <- lapply(CR_types, function(x) vcovCR(lm_full, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(lm_sub, type = x)) expect_equal(CR_full, CR_sub, check.attributes = FALSE) test_full <- lapply(CR_types, function(x) coef_test(lm_full, vcov = x, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) test_sub <- lapply(CR_types, function(x) coef_test(lm_sub, vcov = x, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) expect_equal(test_full, test_sub, check.attributes = FALSE) CR_full <- lapply(CR_types, function(x) vcovCR(lm_full, cluster = LifeCycleSavings$cl, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(lm_sub, cluster = LCS_sub$cl, type = x)) expect_equal(CR_full, CR_sub, check.attributes = FALSE) test_full <- lapply(CR_types, function(x) coef_test(lm_full, vcov = x, cluster = LifeCycleSavings$cl, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) test_sub <- lapply(CR_types, function(x) coef_test(lm_sub, vcov = x, cluster = LCS_sub$cl, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) expect_equal(test_full, test_sub, check.attributes = FALSE) dat_miss <- LifeCycleSavings miss_indicator <- sample.int(n_life, size = round(n_life / 5)) dat_miss$pop15[miss_indicator] <- NA dat_miss$cl[miss_indicator] <- NA with(dat_miss, table(wt, is.na(pop15))) lm_dropped <- lm(cbind(dpi, ddpi) ~ pop15 + pop75 + sr, data = dat_miss, weights = wt) dat_complete <- subset(dat_miss, !is.na(pop15)) lm_complete <- lm(cbind(dpi, ddpi) ~ pop15 + pop75 + sr, data = dat_complete, weights = wt) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, cluster = dat_miss$cl, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, cluster = dat_complete$cl, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, cluster = dat_miss$cl, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, cluster = dat_complete$cl, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) clubSandwich/tests/testthat/test_lme_2level.R0000644000176200001440000002174414630154052021102 0ustar liggesuserscontext("2-level lme objects") set.seed(20190513) # skip_if_not_installed("lme4") skip_if_not_installed("nlme") skip_if_not_installed("mlmRev") # suppressMessages(library(lme4, quietly=TRUE)) library(nlme, quietly=TRUE, warn.conflicts=FALSE) library(mlmRev, quietly=TRUE, warn.conflicts=FALSE) obj_A <- lme(weight ~ Time * Diet, data=BodyWeight, ~ Time | Rat) obj_A2 <- update(obj_A, weights = varPower()) obj_A3 <- update(obj_A, correlation = corExp(form = ~ Time)) obj_A4 <- update(obj_A2, correlation = corExp(form = ~ Time)) obj_B <- lme(distance ~ age, random = ~ age, data = Orthodont) test_that("bread works", { expect_true(check_bread(obj_A, cluster = BodyWeight$Rat, y = BodyWeight$weight)) expect_true(check_bread(obj_A2, cluster = BodyWeight$Rat, y = BodyWeight$weight, tol = 5 * 10^-5)) expect_true(check_bread(obj_A3, cluster = BodyWeight$Rat, y = BodyWeight$weight)) expect_true(check_bread(obj_A4, cluster = BodyWeight$Rat, y = BodyWeight$weight)) expect_true(check_bread(obj_B, cluster = Orthodont$Subject, y = Orthodont$distance)) expect_equal(vcov(obj_A), obj_A$sigma^2 * bread(obj_A) / v_scale(obj_A)) expect_equal(vcov(obj_A2), obj_A2$sigma^2 * bread(obj_A2) / v_scale(obj_A2)) expect_equal(vcov(obj_A3), obj_A3$sigma^2 * bread(obj_A3) / v_scale(obj_A3)) expect_equal(vcov(obj_A4), obj_A4$sigma^2 * bread(obj_A4) / v_scale(obj_A4)) expect_equal(vcov(obj_B), obj_B$sigma^2 * bread(obj_B) / v_scale(obj_B)) }) test_that("vcovCR options work for CR2", { CR2_A <- vcovCR(obj_A, type = "CR2") expect_equal(vcovCR(obj_A, cluster = BodyWeight$Rat, type = "CR2"), CR2_A) expect_equal(vcovCR(obj_A, type = "CR2", inverse_var = TRUE), CR2_A) expect_false(identical(vcovCR(obj_A, type = "CR2", inverse_var = FALSE), CR2_A)) target <- targetVariance(obj_A) expect_equal(vcovCR(obj_A, type = "CR2", target = target, inverse_var = TRUE), CR2_A) attr(CR2_A, "inverse_var") <- FALSE expect_equal(vcovCR(obj_A, type = "CR2", target = target, inverse_var = FALSE), CR2_A) CR2_A2 <- vcovCR(obj_A2, type = "CR2") expect_equal(vcovCR(obj_A2, cluster = BodyWeight$Rat, type = "CR2"), CR2_A2) expect_equal(vcovCR(obj_A2, type = "CR2", inverse_var = TRUE), CR2_A2) expect_false(identical(vcovCR(obj_A2, type = "CR2", inverse_var = FALSE), CR2_A2)) target <- targetVariance(obj_A2) expect_equal(vcovCR(obj_A2, type = "CR2", target = target, inverse_var = TRUE), CR2_A2) attr(CR2_A2, "inverse_var") <- FALSE expect_equal(vcovCR(obj_A2, type = "CR2", target = target, inverse_var = FALSE), CR2_A2) CR2_A3 <- vcovCR(obj_A3, type = "CR2") expect_equal(vcovCR(obj_A3, cluster = BodyWeight$Rat, type = "CR2"), CR2_A3) expect_equal(vcovCR(obj_A3, type = "CR2", inverse_var = TRUE), CR2_A3) expect_false(identical(vcovCR(obj_A3, type = "CR2", inverse_var = FALSE), CR2_A3)) target <- targetVariance(obj_A3) expect_equal(vcovCR(obj_A3, type = "CR2", target = target, inverse_var = TRUE), CR2_A3) attr(CR2_A3, "inverse_var") <- FALSE expect_equal(vcovCR(obj_A3, type = "CR2", target = target, inverse_var = FALSE), CR2_A3) CR2_B <- vcovCR(obj_B, type = "CR2") expect_equal(vcovCR(obj_B, cluster = Orthodont$Subject, type = "CR2"), CR2_B) expect_equal(vcovCR(obj_B, type = "CR2", inverse_var = TRUE), CR2_B) expect_false(identical(vcovCR(obj_B, type = "CR2", inverse_var = FALSE), CR2_B)) target <- targetVariance(obj_B) expect_equal(vcovCR(obj_B, type = "CR2", target = target, inverse_var = TRUE), CR2_B) attr(CR2_B, "inverse_var") <- FALSE expect_equal(vcovCR(obj_B, type = "CR2", target = target, inverse_var = FALSE), CR2_B) }) test_that("vcovCR options work for CR4", { CR4_A <- vcovCR(obj_A, type = "CR4") expect_equal(vcovCR(obj_A, cluster = BodyWeight$Rat, type = "CR4"), CR4_A) expect_equal(vcovCR(obj_A, type = "CR4", inverse_var = TRUE), CR4_A) expect_false(identical(vcovCR(obj_A, type = "CR4", inverse_var = FALSE), CR4_A)) target <- targetVariance(obj_A) expect_equal(vcovCR(obj_A, type = "CR4", target = target, inverse_var = TRUE), CR4_A) attr(CR4_A, "inverse_var") <- FALSE expect_equal(vcovCR(obj_A, type = "CR4", target = target, inverse_var = FALSE), CR4_A) CR4_B <- vcovCR(obj_B, type = "CR4") expect_equal(vcovCR(obj_B, cluster = Orthodont$Subject, type = "CR4"), CR4_B) expect_equal(vcovCR(obj_B, type = "CR4", inverse_var = TRUE), CR4_B) expect_false(identical(vcovCR(obj_B, type = "CR4", inverse_var = FALSE), CR4_B)) target <- targetVariance(obj_B) expect_equal(vcovCR(obj_B, type = "CR4", target = target, inverse_var = TRUE), CR4_B) attr(CR4_B, "inverse_var") <- FALSE expect_equal(vcovCR(obj_B, type = "CR4", target = target, inverse_var = FALSE), CR4_B) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(obj_A, vcov = "CR2")) expect_true(check_CR(obj_B, vcov = "CR2")) expect_true(check_CR(obj_A, vcov = "CR4")) expect_true(check_CR(obj_B, vcov = "CR4")) }) CR_types <- paste0("CR",0:4) test_that("Order doesn't matter.", { check_sort_order(obj_A, BodyWeight) }) test_that("clubSandwich works with dropped observations", { dat_miss <- BodyWeight dat_miss$weight[sample.int(nrow(BodyWeight), size = round(nrow(BodyWeight) / 10))] <- NA obj_dropped <- update(obj_A, data = dat_miss, na.action = na.omit) obj_complete <- update(obj_A, data = dat_miss, subset = !is.na(weight)) CR_drop <- lapply(CR_types, function(x) vcovCR(obj_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(obj_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(obj_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(obj_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("lme agrees with gls", { lme_fit <- lme(weight ~ Time * Diet, data=BodyWeight, ~ 1 | Rat) gls_fit <- gls(weight ~ Time * Diet, data=BodyWeight, correlation = corCompSymm(form = ~ 1 | Rat)) CR_lme <- lapply(CR_types, function(x) vcovCR(lme_fit, type = x)) CR_gls <- lapply(CR_types, function(x) vcovCR(gls_fit, type = x)) # max_ratio <- mapply(function(a, b) max(abs(a / b - 1)), CR_lme, CR_gls) # expect_true(all(max_ratio < 10^-4)) expect_equivalent(CR_lme, CR_gls, tolerance = 10^-4) test_lme <- lapply(CR_types, function(x) coef_test(lme_fit, vcov = x, test = "All", p_values = FALSE)) test_gls <- lapply(CR_types, function(x) coef_test(gls_fit, vcov = x, test = "All", p_values = FALSE)) compare_ttests(test_lme, test_gls) constraints <- c(combn(length(coef(lme_fit)), 2, simplify = FALSE), combn(length(coef(lme_fit)), 3, simplify = FALSE)) Wald_lme <- Wald_test(lme_fit, constraints = constrain_zero(constraints), vcov = "CR2", test = "All") Wald_gls <- Wald_test(gls_fit, constraints = constrain_zero(constraints), vcov = "CR2", test = "All") compare_Waldtests(Wald_lme, Wald_gls) }) test_that("Emply levels are dropped in model_matrix", { data(AchievementAwardsRCT) AA_RCT_females <- subset(AchievementAwardsRCT, sex=="Girl" & year != "1999") AA_RCT_females <- within(AA_RCT_females, { sibs_4 <- siblings >= 4 treated2001 <- treated * (year=="2001") }) lme_fit <- lme(Bagrut_status ~ year * school_type + father_ed + mother_ed + immigrant + sibs_4 + qrtl + treated2001:half, random = ~ 1 | school_id, data = AA_RCT_females) betas <- fixef(lme_fit) X <- model_matrix(lme_fit) expect_identical(names(betas), colnames(X)) }) test_that("Possible to cluster at higher level than random effects", { n_districts <- 10 n_schools_per <- rnbinom(n_districts, size = 4, prob = 0.3) n_schools <- sum(n_schools_per) n_students_per <- 10 n_students <- n_schools * n_students_per # identifiers for each level district_id <- factor(rep(1:n_districts, n_schools_per * n_students_per)) school_id <- factor(rep(1:sum(n_schools_per), each = n_students_per)) student_id <- 1:n_students # simulated outcome Y <- rnorm(n_districts)[district_id] + rnorm(n_schools)[school_id] + rnorm(n_students) X <- rnorm(n_students) dat <- data.frame(district_id, school_id, student_id, Y, X) dat_scramble <- dat[sample(nrow(dat)),] # fit two-level model lme_2level <- lme(Y ~ X, random = ~ 1 | school_id, data = dat) # cluster at level 3 V <- vcovCR(lme_2level, type = "CR2", cluster = dat$district_id) expect_is(V, "vcovCR") expect_error(vcovCR(lme_2level, type = "CR2", cluster = dat_scramble$district_id)) # check that result does not depend on sort-order V_scramble <- vcovCR(lme(Y ~ X, random = ~ 1 | school_id, data = dat_scramble), type = "CR2", cluster = dat_scramble$district_id) expect_equal(as.matrix(V), as.matrix(V_scramble)) }) clubSandwich/tests/testthat/test_conf_int.R0000644000176200001440000001000514630154052020637 0ustar liggesuserscontext("confidence intervals") set.seed(20190513) skip_if_not_installed("nlme") library(nlme, quietly=TRUE, warn.conflicts=FALSE) data(Ovary, package = "nlme") Ovary$time_int <- 1:nrow(Ovary) gls_fit <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = Ovary, correlation = corAR1(form = ~ time_int | Mare), weights = varPower()) CRs <- paste0("CR", 0:4) test_that("vcov arguments work", { VCR <- lapply(CRs, function(t) vcovCR(gls_fit, type = t)) CI_A <- lapply(VCR, function(v) conf_int(gls_fit, vcov = v, level = .98)) CI_B <- lapply(CRs, function(t) conf_int(gls_fit, vcov = t, level = .98)) expect_equal(CI_A, CI_B) }) test_that("coefs argument works", { which_grid <- expand.grid(rep(list(c(FALSE,TRUE)), length(coef(gls_fit)))) tests_all <- conf_int(gls_fit, vcov = "CR0", coefs = "All") CI_A <- apply(which_grid[-1,], 1, function(x) tests_all[x,]) CI_B <- apply(which_grid[-1,], 1, function(x) conf_int(gls_fit, vcov = "CR0", coefs = x)) expect_equal(CI_A, CI_B) }) test_that("printing works", { CIs <- conf_int(gls_fit, vcov = "CR0") expect_output(print(CIs)) CIs <- conf_int(gls_fit, vcov = "CR0", p_values = TRUE) expect_output(x <- print(CIs)) expect_true(all(c("p-value","Sig.") %in% names(x))) }) test_that("level checks work", { expect_error(conf_int(gls_fit, vcov = "CR0", level = -0.01)) expect_error(conf_int(gls_fit, vcov = "CR0", level = 95)) expect_output(print(conf_int(gls_fit, vcov = "CR0", level = runif(1)))) }) test_that("CI boundaries are ordered", { lev <- runif(1) CI_z <- conf_int(gls_fit, vcov = "CR0", test = "z", level = lev) CI_t <- conf_int(gls_fit, vcov = "CR0", test = "naive-t", level = lev) CI_Satt <- conf_int(gls_fit, vcov = "CR0", test = "Satterthwaite", level = lev) expect_true(all(CI_t$CI_L < CI_z$CI_L)) expect_true(all(CI_t$CI_U > CI_z$CI_U)) expect_true(all(CI_Satt$CI_L < CI_z$CI_L)) expect_true(all(CI_Satt$CI_U > CI_z$CI_U)) }) test_that("conf_int() is consistent with coef_test()", { lev <- runif(1) CIs <- lapply(CRs, function(v) conf_int(gls_fit, vcov = v, test = "Satterthwaite", level = lev, p_values = TRUE)) ttests <- lapply(CRs, function(v) coef_test(gls_fit, vcov = v, test = "Satterthwaite")) CI_L <- lapply(ttests, function(x) x$beta - x$SE * qt(1 - (1 - lev) / 2, df = x$df)) CI_U <- lapply(ttests, function(x) x$beta + x$SE * qt(1 - (1 - lev) / 2, df = x$df)) expect_equal(lapply(CIs, function(x) x$CI_L), CI_L) expect_equal(lapply(CIs, function(x) x$CI_U), CI_U) expect_equal(lapply(CIs, function(x) x$p_val), lapply(ttests, function(x) x$p_Satt)) lev <- runif(1) CIs <- lapply(CRs, function(v) conf_int(gls_fit, vcov = v, test = "naive-t", level = lev, p_values = TRUE)) ttests <- lapply(CRs, function(v) coef_test(gls_fit, vcov = v, test = "naive-t")) CI_L <- lapply(ttests, function(x) x$beta - x$SE * qt(1 - (1 - lev) / 2, df = x$df)) CI_U <- lapply(ttests, function(x) x$beta + x$SE * qt(1 - (1 - lev) / 2, df = x$df)) expect_equal(lapply(CIs, function(x) x$CI_L), CI_L) expect_equal(lapply(CIs, function(x) x$CI_U), CI_U) expect_equal(lapply(CIs, function(x) x$p_val), lapply(ttests, function(x) x$p_t)) lev <- runif(1) CIs <- lapply(CRs, function(v) conf_int(gls_fit, vcov = v, test = "z", level = lev, p_values = TRUE)) ttests <- lapply(CRs, function(v) coef_test(gls_fit, vcov = v, test = "z")) CI_L <- lapply(ttests, function(x) x$beta - x$SE * qt(1 - (1 - lev) / 2, df = x$df)) CI_U <- lapply(ttests, function(x) x$beta + x$SE * qt(1 - (1 - lev) / 2, df = x$df)) expect_equal(lapply(CIs, function(x) x$CI_L), CI_L) expect_equal(lapply(CIs, function(x) x$CI_U), CI_U) expect_equal(lapply(CIs, function(x) x$p_val), lapply(ttests, function(x) x$p_z)) }) test_that("conf_int has informative error messages.", { expect_error( conf_int(gls_fit, vcov = "CR0", test = "all") ) expect_error( conf_int(gls_fit, vcov = "CR0", test = "saddlepoint") ) }) clubSandwich/tests/testthat/test_rma-ls.R0000644000176200001440000000644614630154052020251 0ustar liggesuserscontext("rma.uni location-scale models") skip_if_not_installed("metadat") skip_if_not_installed("metafor", minimum_version = "3.4-0") library(metadat) suppressMessages(library(metafor, quietly=TRUE)) dat <- dat.bangertdrowns2004 dat$ni100 <- dat$ni/100 dat$meta[is.na(dat$meta)] <- 0 res <- rma(yi, vi, mods = ~ ni100 + meta, scale = ~ ni100 + imag, data = dat) test_that("bread works", { expect_true(check_bread(res, cluster = dat$id, y = dat$yi)) vcov_mat <- bread(res) / nobs(res) attr(vcov_mat, "dimnames") <- attr(vcov(res)$beta, "dimnames") expect_equal(vcov(res)$beta, vcov_mat) }) CR_types <- paste0("CR",0:4) test_that("order doesn't matter", { skip_on_cran() check_sort_order(res, dat, cluster = "id") }) test_that("clubSandwich works with dropped covariates", { dat_miss <- dat.bangertdrowns2004 expect_warning(res_drop <- rma(yi, vi, mods = ~ length + feedback + info, scale = ~ wic, data = dat)) subset_ind <- with(dat_miss, complete.cases(length, feedback, info, wic, yi, vi)) res_complete <- rma(yi, vi, mods = ~ length + feedback + info, scale = ~ wic, data = dat_miss[subset_ind,]) expect_error(vcovCR(res_complete, type = "CR0", cluster = dat_miss$id)) CR_drop <- lapply(CR_types, function(x) vcovCR(res_drop, type = x, cluster = dat_miss$id)) CR_complete <- lapply(CR_types, function(x) vcovCR(res_complete, type = x, cluster = dat_miss$id[subset_ind])) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(res_drop, vcov = x, cluster = dat_miss$id, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(res_complete, vcov = x, cluster = dat_miss$id[subset_ind], test = "All", p_values = FALSE)) compare_ttests(test_drop, test_complete) }) test_that("clubSandwich works with missing variances", { dat_miss <- dat dat_miss$vi[sample.int(nrow(dat_miss), size = round(nrow(dat_miss) / 10))] <- NA expect_warning(res_drop <- rma(yi, vi, mods = ~ ni100 + meta, scale = ~ ni100 + imag, data = dat_miss)) subset_ind <- with(dat_miss, !is.na(vi)) res_complete <- rma(yi, vi, mods = ~ ni100 + meta, scale = ~ ni100 + imag, data = dat_miss, subset = !is.na(vi)) expect_error(vcovCR(res_complete, type = "CR0", cluster = dat_miss$id)) CR_drop <- lapply(CR_types, function(x) vcovCR(res_drop, type = x, cluster = dat_miss$id)) CR_complete <- lapply(CR_types, function(x) vcovCR(res_complete, type = x, cluster = dat_miss$id[subset_ind])) expect_equal(CR_drop, CR_complete) }) test_that("vcovCR options work for CR2", { RE_var <- res$tau2 + dat$vi CR2_iv <- vcovCR(res, type = "CR2", cluster = dat$id) expect_equal(vcovCR(res, type = "CR2", cluster = dat$id, inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(res, type = "CR2", cluster = dat$id, inverse_var = FALSE) attr(CR2_iv, "inverse_var") <- FALSE attr(CR2_iv, "target") <- attr(CR2_not, "target") expect_equal(CR2_not, CR2_iv) expect_equal(vcovCR(res, type = "CR2", cluster = dat$id, target = RE_var), CR2_not) expect_equal(vcovCR(res, type = "CR2", cluster = dat$id, target = RE_var, inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(res, type = "CR2", cluster = dat$id, target = dat$vi), CR2_not)) }) clubSandwich/tests/testthat/test_estfun.R0000644000176200001440000000573014630154052020355 0ustar liggesuserscontext("estfun objects") skip_if_not_installed("zoo") skip_if_not_installed("AER") library(zoo, quietly=TRUE) library(AER, quietly=TRUE) CR_types <- paste0("CR",0:4) data("CigarettesSW", package = "AER") Cigs <- within(CigarettesSW, { rprice <- price/cpi rincome <- income/population/cpi tdiff <- (taxs - tax)/cpi }) obj_un <- ivreg(log(packs) ~ log(rprice) + log(rincome) + I(tax/cpi) | log(rincome) + tdiff + I(tax/cpi), data = Cigs) obj_wt <- ivreg(log(packs) ~ log(rprice) + log(rincome) + I(tax/cpi) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, weights = population) red_form_un <- lm(log(packs) ~ log(rincome) + I(tax/cpi) + tdiff, data = Cigs) red_form_wt <- lm(log(packs) ~ log(rincome) + I(tax/cpi) + tdiff, data = Cigs, weights = population) stage1_un <- lm(log(rprice) ~ log(rincome) + I(tax/cpi) + tdiff, data = Cigs) stage1_wt <- lm(log(rprice) ~ log(rincome) + I(tax/cpi) + tdiff, data = Cigs, weights = population) test_that("estfun works for lm.", { V_CR <- lapply(CR_types, function(type) as.matrix(vcovCR(obj = red_form_un, cluster = Cigs$state, type = type))) e_CR <- lapply(CR_types, function(type) vcovCR(obj = red_form_un, cluster = Cigs$state, type = type, form = "estfun")) expect_equal(lapply(e_CR, tcrossprod), V_CR) V_CR <- lapply(CR_types, function(type) as.matrix(vcovCR(obj = red_form_wt, cluster = Cigs$state, type = type))) e_CR <- lapply(CR_types, function(type) vcovCR(obj = red_form_wt, cluster = Cigs$state, type = type, form = "estfun")) expect_equal(lapply(e_CR, tcrossprod), V_CR) V_CR <- lapply(CR_types, function(type) as.matrix(vcovCR(obj = stage1_un, cluster = Cigs$state, type = type))) e_CR <- lapply(CR_types, function(type) vcovCR(obj = stage1_un, cluster = Cigs$state, type = type, form = "estfun")) expect_equal(lapply(e_CR, tcrossprod), V_CR) V_CR <- lapply(CR_types, function(type) as.matrix(vcovCR(obj = stage1_wt, cluster = Cigs$state, type = type))) e_CR <- lapply(CR_types, function(type) vcovCR(obj = stage1_wt, cluster = Cigs$state, type = type, form = "estfun")) expect_equal(lapply(e_CR, tcrossprod), V_CR) }) test_that("stacked estimating equations are equivalent to 2SLS.", { e_CR <- lapply(CR_types, function(type) vcovCR(obj = red_form_un, cluster = Cigs$state, type = type, form = "estfun")) f_CR <- lapply(CR_types, function(type) vcovCR(obj = stage1_un, cluster = Cigs$state, type = type, form = "estfun")) V_CR_stack <- mapply(function(x, y) tcrossprod(rbind(x, y)), x = e_CR, y = f_CR, SIMPLIFY = FALSE) gamma <- coef(stage1_un)["tdiff"] beta <- coef(red_form_un)["tdiff"] delta <- beta / gamma V_CR_2SLS <- lapply(CR_types, function(type) vcovCR(obj = obj_un, cluster = Cigs$state, type = type)) V_CR_2SLS <- sapply(V_CR_2SLS, function(x) diag(x)["log(rprice)"]) V_delta <- sapply(V_CR_stack, function(x) sum(x[c(4,8), c(4,8)] * tcrossprod(c(1,-delta))) / gamma^2) }) clubSandwich/tests/testthat/test_plm-unbalanced-fixed-effects.R0000644000176200001440000003150314630154052024442 0ustar liggesuserscontext("plm objects - unbalanced fixed effects") set.seed(20190513) skip_if_not_installed("plm") library(plm, quietly=TRUE) #------------------------------------- # Produc example #------------------------------------- data("Produc", package = "plm") Produc$gsp[sample(nrow(Produc), size = 75)] <- NA Produc$cluster <- sample(LETTERS[1:10], size = nrow(Produc), replace=TRUE) n <- nrow(Produc) n_obs <- sum(!is.na(Produc$gsp)) plm_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year"), effect = "individual", model = "within") lm_individual <- lm(log(gsp) ~ 0 + state + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) individual_names <- names(coef(plm_individual)) individual_index <- names(coef(lm_individual)) %in% individual_names target <- as.vector(1 / plm_individual$model$"log(emp)") test_that("individual effects agree with lm", { expect_equal(coef(plm_individual), coef(lm_individual)[individual_index]) expect_equal(vcovCR(plm_individual, type="CR0")[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR0")[individual_index,individual_index]) expect_equal(vcovCR(plm_individual, type="CR1")[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR1")[individual_index,individual_index]) expect_equal(vcovCR(plm_individual, type="CR2")[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR2")[individual_index,individual_index]) expect_equal(vcovCR(plm_individual, type="CR2", inverse_var=FALSE)[individual_names,individual_names], vcovCR(lm_individual, cluster = Produc$state, type = "CR2")[individual_index,individual_index]) }) plm_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year"), effect = "time", model = "within") lm_time <- lm(log(gsp) ~ 0 + factor(year) + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) time_names <- names(coef(plm_time)) time_index <- names(coef(lm_time)) %in% time_names test_that("time effects agree with lm", { expect_equal(coef(plm_time), coef(lm_time)[time_index]) expect_equal(vcovCR(plm_time, type="CR0")[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR0")[time_index,time_index]) expect_equal(vcovCR(plm_time, type="CR1")[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR1")[time_index,time_index]) expect_equal(vcovCR(plm_time, type="CR2")[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR2")[time_index,time_index]) expect_equal(vcovCR(plm_time, type="CR2", inverse_var=FALSE)[time_names,time_names], vcovCR(lm_time, cluster = Produc$year, type = "CR2")[time_index,time_index]) }) plm_twoways <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year"), effect = "twoways", model = "within") lm_twoways <- lm(log(gsp) ~ 0 + state + factor(year) + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) twoway_names <- names(coef(plm_twoways)) twoway_index <- names(coef(lm_twoways)) %in% twoway_names test_that("two-way effects agree with lm", { expect_equal(coef(plm_twoways), coef(lm_twoways)[twoway_index]) # clustering on individual expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR0")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR0")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR1")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR1")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR2")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR2")[twoway_index,twoway_index], tolerance = 10^-5) expect_equal(vcovCR(plm_twoways, cluster = "individual", type="CR2", inverse_var=FALSE)[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$state, type = "CR2")[twoway_index,twoway_index], tolerance = 10^-5) # clustering on time expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR0")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR0")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR1")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR1")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR2")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR2")[twoway_index,twoway_index], tolerance = 10^-5) expect_equal(vcovCR(plm_twoways, cluster = "time", type="CR2", inverse_var=FALSE)[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$year, type = "CR2")[twoway_index,twoway_index], tolerance = 10^-5) # clustering on a randomly generated factor expect_equal(vcovCR(plm_twoways, cluster = Produc$cluster, type="CR0")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR0")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = Produc$cluster, type="CR1")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR1")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = Produc$cluster, type="CR2")[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR2")[twoway_index,twoway_index]) expect_equal(vcovCR(plm_twoways, cluster = Produc$cluster, type="CR2", inverse_var=FALSE)[twoway_names,twoway_names], vcovCR(lm_twoways, cluster = Produc$cluster, type = "CR2")[twoway_index,twoway_index]) }) test_that("bread works", { y <- plm_individual$model$"log(gsp)" expect_true(check_bread(plm_individual, cluster = findCluster.plm(plm_individual), y = y)) sigma_sq_ind <- with(plm_individual, sum(residuals^2) / df.residual) expect_equal(vcov(plm_individual), bread(plm_individual) * sigma_sq_ind / v_scale(plm_individual)) expect_true(check_bread(plm_time, cluster = findCluster.plm(plm_time), y = y)) sigma_sq_time <- with(plm_time, sum(residuals^2) / df.residual) expect_equal(vcov(plm_time), bread(plm_time) * sigma_sq_time / v_scale(plm_time)) expect_true(check_bread(plm_twoways, cluster = findCluster.plm(plm_twoways, "state"), y = y)) expect_true(check_bread(plm_twoways, cluster = findCluster.plm(plm_twoways, "year"), y = y)) sigma_sq_two <- with(plm_twoways, sum(residuals^2) / df.residual) expect_equal(vcov(plm_twoways), bread(plm_twoways) * sigma_sq_two / v_scale(plm_twoways)) }) test_that("CR0 and CR1S agree with arellano vcov", { expect_equal(vcovHC(plm_individual, method="arellano", type = "HC0", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_individual, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR1S")), check.attributes = FALSE) expect_equal(vcovHC(plm_time, method="arellano", type = "HC0", cluster = "time"), as.matrix(vcovCR(plm_time, type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_time, method="arellano", type = "sss", cluster = "time"), as.matrix(vcovCR(plm_time, type = "CR1S")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "HC0", cluster = "group"), as.matrix(vcovCR(plm_twoways, cluster = "individual", type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_twoways, cluster = "individual", type = "CR1S")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "HC0", cluster = "time"), as.matrix(vcovCR(plm_twoways, cluster = "time", type = "CR0")), check.attributes = FALSE) expect_equal(vcovHC(plm_twoways, method="arellano", type = "sss", cluster = "time"), as.matrix(vcovCR(plm_twoways, cluster = "time", type = "CR1S")), check.attributes = FALSE) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(plm_individual, type = "CR2") expect_equal(vcovCR(plm_individual, cluster = Produc$state, type = "CR2"), CR2_iv) expect_equal(vcovCR(plm_individual, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(plm_individual, type = "CR2", target = rep(1, n_obs), inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(plm_individual, type = "CR2", inverse_var = FALSE) expect_equivalent(CR2_not, CR2_iv) expect_equal(vcovCR(plm_individual, cluster = Produc$state, type = "CR2", inverse_var = FALSE), CR2_not) expect_equal(vcovCR(plm_individual, type = "CR2", target = rep(1, n_obs)), CR2_not) expect_equal(vcovCR(plm_individual, type = "CR2", target = rep(1, n_obs), inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(plm_individual, type = "CR2", target = target), CR2_not)) }) test_that("vcovCR options work for CR4", { CR4_iv <- vcovCR(plm_individual, type = "CR4") expect_equal(vcovCR(plm_individual, cluster = Produc$state, type = "CR4"), CR4_iv) expect_equal(vcovCR(plm_individual, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(plm_individual, type = "CR4", target = rep(1, n_obs), inverse_var = TRUE), CR4_iv) CR4_not <- vcovCR(plm_individual, type = "CR4", inverse_var = FALSE) expect_equivalent(CR4_not, CR4_iv) expect_equal(vcovCR(plm_individual, cluster = Produc$state, type = "CR4", inverse_var = FALSE), CR4_not) expect_equal(vcovCR(plm_individual, type = "CR4", target = rep(1, n_obs)), CR4_not) expect_equal(vcovCR(plm_individual, type = "CR4", target = rep(1, n_obs), inverse_var = FALSE), CR4_not) expect_false(identical(vcovCR(plm_individual, type = "CR4", target = target), CR4_not)) }) test_that("CR2 and CR4 are target-unbiased", { skip_on_cran() expect_true(check_CR(plm_individual, vcov = "CR2")) expect_true(check_CR(plm_individual, vcov = "CR4")) expect_true(check_CR(plm_individual, vcov = "CR2", inverse_var = FALSE)) expect_true(check_CR(plm_individual, vcov = "CR4", inverse_var = FALSE)) expect_true(check_CR(plm_time, vcov = "CR2")) expect_true(check_CR(plm_time, vcov = "CR4")) expect_true(check_CR(plm_time, vcov = "CR2", inverse_var = FALSE)) expect_true(check_CR(plm_time, vcov = "CR4", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "individual")) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "individual")) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "individual", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "individual", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "time")) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "time")) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = "time", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = "time", inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = Produc$cluster)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = Produc$cluster)) expect_true(check_CR(plm_twoways, vcov = "CR2", cluster = Produc$cluster, inverse_var = FALSE)) expect_true(check_CR(plm_twoways, vcov = "CR4", cluster = Produc$cluster, inverse_var = FALSE)) }) test_that("vcovCR is equivalent to vcovHC when clusters are all of size 1", { library(sandwich, quietly=TRUE) CR_types <- paste0("CR",c(0,2)) HC_types <- paste0("HC",c(0,2)) CR_individual <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_individual, cluster = 1:n, type = t))) HC_individual <- lapply(HC_types, function(t) vcovHC(lm_individual, type = t)[individual_index,individual_index]) expect_equal(CR_individual, HC_individual) CR_time <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_time, cluster = 1:n, type = t))) HC_time <- lapply(HC_types, function(t) vcovHC(lm_time, type = t)[time_index,time_index]) expect_equal(CR_time, HC_time) CR_twoways <- lapply(CR_types, function(t) as.matrix(vcovCR(plm_twoways, cluster = 1:n, type = t))) HC_twoways <- lapply(HC_types, function(t) vcovHC(lm_twoways, type = t)[twoway_index,twoway_index]) expect_equal(CR_twoways, HC_twoways) }) clubSandwich/tests/testthat/test_lm.R0000644000176200001440000004250214630154052017457 0ustar liggesuserscontext("lm objects") set.seed(20190513) m <- 8 cluster <- factor(rep(LETTERS[1:m], 3 + rpois(m, 5))) n <- length(cluster) const <- rep("whuzzup.", n) X <- matrix(rnorm(3 * n), n, 3) nu <- rnorm(m)[cluster] e <- rnorm(n) w <- rgamma(n, shape = 3, scale = 3) y <- X %*% c(.4, .3, -.3) + nu + e dat <- data.frame(y, X, cluster, const, w, row = 1:n) lm_fit <- lm(y ~ X1 + X2 + X3, data = dat) WLS_fit <- lm(y ~ X1 + X2 + X3, data = dat, weights = w) CR_types <- paste0("CR",0:4) # obj <- WLS_fit # y <- dat$y # type <- "CR2" # vcov <- vcovCR(obj, cluster = cluster, type = type) # target = NULL # inverse_var = FALSE test_that("bread works", { expect_true(check_bread(lm_fit, cluster = dat$cluster, y = dat$y)) lm_vcov <- bread(lm_fit) * summary(lm_fit)$sigma^2 / v_scale(lm_fit) expect_equal(vcov(lm_fit), lm_vcov) expect_true(check_bread(WLS_fit, cluster = dat$cluster, y = dat$y)) wls_vcov <- bread(WLS_fit) * summary(WLS_fit)$sigma^2 / v_scale(WLS_fit) expect_equal(vcov(WLS_fit), wls_vcov) }) test_that("vcovCR options don't matter for CR0", { expect_error(vcovCR(lm_fit, type = "CR0")) CR0 <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR0") expect_output(print(CR0)) attr(CR0, "target") <- NULL attr(CR0, "inverse_var") <- NULL CR0_A <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR0", target = 1 / dat$w) attr(CR0_A, "target") <- NULL attr(CR0_A, "inverse_var") <- NULL expect_identical(CR0_A, CR0) CR0_B <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR0", target = 1 / dat$w, inverse_var = FALSE) attr(CR0_B, "target") <- NULL attr(CR0_B, "inverse_var") <- NULL expect_identical(CR0_A, CR0) CR0_C <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR0", target = 1 / dat$w, inverse_var = TRUE) attr(CR0_C, "target") <- NULL attr(CR0_C, "inverse_var") <- NULL expect_identical(CR0_C, CR0) wCR0 <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR0") attr(wCR0, "target") <- NULL attr(wCR0, "inverse_var") <- NULL wCR0_A <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR0", target = 1 / dat$w) attr(wCR0_A, "target") <- NULL attr(wCR0_A, "inverse_var") <- NULL expect_identical(wCR0_A, wCR0) wCR0_B <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR0", target = 1 / dat$w, inverse_var = FALSE) attr(wCR0_B, "target") <- NULL attr(wCR0_B, "inverse_var") <- NULL expect_identical(wCR0_B, wCR0) wCR0_C <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR0", target = 1 / dat$w, inverse_var = TRUE) attr(wCR0_C, "target") <- NULL attr(wCR0_C, "inverse_var") <- NULL expect_identical(wCR0_C, wCR0) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR2") expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR2", target = rep(1, n), inverse_var = TRUE), CR2_iv) attr(CR2_iv, "inverse_var") <- FALSE CR2_not <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR2", inverse_var = FALSE) expect_equal(CR2_not, CR2_iv) expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR2", target = rep(1, n)), CR2_not) expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR2", target = rep(1, n), inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(lm_fit, cluster = dat$cluster, type = "CR2", target = 1 / dat$w), CR2_not)) wCR2_id <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2") expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2", inverse_var = FALSE), wCR2_id) expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2", target = rep(1, n)), wCR2_id) expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2", target = rep(1, n), inverse_var = FALSE), wCR2_id) wCR2_iv <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2", inverse_var = TRUE) wCR2_target <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2", target = 1 / dat$w, inverse_var = TRUE) expect_false(identical(wCR2_target, wCR2_id)) expect_equal(matrix(wCR2_target, dim(wCR2_target)), matrix(wCR2_iv, dim(wCR2_iv))) expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR2", target = 1 / dat$w, inverse_var = TRUE), wCR2_target) }) test_that("vcovCR options work for CR4", { CR4_iv <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR4") expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR4", inverse_var = TRUE), CR4_iv) expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR4", target = rep(1, n), inverse_var = TRUE), CR4_iv) attr(CR4_iv, "inverse_var") <- FALSE CR4_not <- vcovCR(lm_fit, cluster = dat$cluster, type = "CR4", inverse_var = FALSE) expect_equal(CR4_not, CR4_iv) expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR4", target = rep(1, n)), CR4_not) expect_equal(vcovCR(lm_fit, cluster = dat$cluster, type = "CR4", target = rep(1, n), inverse_var = FALSE), CR4_not) expect_false(identical(vcovCR(lm_fit, cluster = dat$cluster, type = "CR4", target = 1 / dat$w), CR4_not)) wCR4_id <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4") expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4", inverse_var = FALSE), wCR4_id) expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4", target = rep(1, n)), wCR4_id) expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4", target = rep(1, n), inverse_var = FALSE), wCR4_id) wCR4_iv <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4", inverse_var = TRUE) wCR4_target <- vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4", target = 1 / dat$w, inverse_var = TRUE) expect_false(identical(wCR4_target, wCR4_id)) expect_equal(matrix(wCR4_target, dim(wCR4_target)), matrix(wCR4_iv, dim(wCR4_iv))) expect_equal(vcovCR(WLS_fit, cluster = dat$cluster, type = "CR4", target = 1 / dat$w, inverse_var = TRUE), wCR4_target) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(lm_fit, vcov = "CR2", cluster = dat$cluster)) expect_true(check_CR(WLS_fit, vcov = "CR2", cluster = dat$cluster)) expect_true(check_CR(lm_fit, vcov = "CR4", cluster = dat$cluster)) expect_true(check_CR(WLS_fit, vcov = "CR4", cluster = dat$cluster)) }) test_that("vcovCR is equivalent to vcovHC when clusters are all of size 1", { library(sandwich, quietly=TRUE) CR0 <- vcovCR(lm_fit, cluster = dat$row, type = "CR0") expect_equal(vcovHC(lm_fit, type = "HC0"), as.matrix(CR0)) CR1 <- vcovCR(lm_fit, cluster = dat$row, type = "CR1S") expect_equal(vcovHC(lm_fit, type = "HC1"), as.matrix(CR1)) CR2 <- vcovCR(lm_fit, cluster = dat$row, type = "CR2") expect_equal(vcovHC(lm_fit, type = "HC2"), as.matrix(CR2)) CR3 <- vcovCR(lm_fit, cluster = dat$row, type = "CR3") expect_equal(vcovHC(lm_fit, type = "HC3"), as.matrix(CR3)) }) test_that("CR2 is equivalent to Welch t-test for DiD design", { m0 <- 4 m1 <- 9 m <- m0 + m1 cluster <- factor(rep(LETTERS[1:m], each = 2)) n <- length(cluster) time <- rep(c(1,2), m) trt_clusters <- c(rep(0,m0), rep(1,m1)) trt <- (time - 1) * rep(trt_clusters, each = 2) nu <- rnorm(m)[cluster] e <- rnorm(n) y <- 0.4 * trt + nu + e dat <- data.frame(y, time, trt, cluster) lm_DID <- lm(y ~ cluster + factor(time) + trt, data = dat) t_Satt <- coef_test(lm_DID, vcov = "CR2", cluster = dat$cluster)["trt",] y_diff <- apply(matrix(y, nrow = 2), 2, diff) t_Welch <- t.test(y_diff ~ trt_clusters) expect_equal(with(t_Welch, estimate[[2]] - estimate[[1]]), t_Satt$beta) expect_equal(as.numeric(-t_Welch$statistic), with(t_Satt, beta / SE)) expect_is(all.equal(as.numeric(t_Welch$parameter), t_Satt$df), "character") df <- m^2 * (m0 - 1) * (m1 - 1) / (m0^2 * (m0 - 1) + m1^2 * (m1 - 1)) expect_equal(t_Satt$df, df) }) test_that("Order doesn't matter.",{ check_sort_order(WLS_fit, dat, "cluster") }) test_that("clubSandwich works with dropped observations", { dat_miss <- dat miss_indicator <- sample.int(n, size = round(n / 10)) dat_miss$X1[miss_indicator] <- NA dat_miss$cluster[miss_indicator] <- NA lm_dropped <- lm(y ~ X1 + X2 + X3, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(X1)) lm_complete <- lm(y ~ X1 + X2 + X3, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, cluster = dat_miss$cluster, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, cluster = dat_complete$cluster, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, cluster = dat_miss$cluster, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, cluster = dat_complete$cluster, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("clubSandwich requires no missing values on the clustering variable", { dat_miss <- dat miss_indicator <- sample.int(n, size = round(n / 10)) dat_miss$cluster[miss_indicator] <- NA lm_dropped <- lm(y ~ X1 + X2 + X3, data = dat_miss) expect_error(vcovCR(lm_dropped, cluster = dat_miss$cluster, type = "CR0"), "Clustering variable cannot have missing values.") expect_error(coef_test(lm_dropped, vcov = "CR0", cluster = dat_miss$cluster, test = "All"), "Clustering variable cannot have missing values.") }) test_that("clubSandwich works with aliased predictors", { data(npk, package = "datasets") npk_alias <- lm(yield ~ block + N*P*K, npk) npk_drop <- lm(yield ~ block + N + P + K + N:P + N:K + P:K, npk) CR_alias <- lapply(CR_types[-4], function(x) vcovCR(npk_alias, cluster = npk$block, type = x)) CR_drop <- lapply(CR_types[-4], function(x) vcovCR(npk_drop, cluster = npk$block, type = x)) expect_equal(CR_alias, CR_drop) test_drop <- lapply(CR_types[-4], function(x) coef_test(npk_alias, vcov = x, cluster = npk$block, test = c("z","naive-t","Satterthwaite"), coefs = 7:12, p_values = FALSE)) test_complete <- lapply(CR_types[-4], function(x) coef_test(npk_drop, vcov = x, cluster = npk$block, test = c("z","naive-t","Satterthwaite"), coefs = 7:12, p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("weight scale doesn't matter", { lm_fit_w <- lm(y ~ X1 + X2 + X3, data = dat, weights = rep(4, nrow(dat))) unweighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit, cluster = cluster, type = x)) weighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit_w, cluster = cluster, type = x)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix), tol = 5 * 10^-7) target <- 1 + rpois(nrow(dat), lambda = 8) unweighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit, cluster = cluster, type = x, target = target)) weighted_fit <- lapply(CR_types, function(x) vcovCR(lm_fit_w, cluster = cluster, type = x, target = target * 15)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix), tol = 5 * 10^-7) }) test_that("clubSandwich works with weights of zero.", { data("LifeCycleSavings", package = "datasets") n_life <- nrow(LifeCycleSavings) LifeCycleSavings$cl <- substr(rownames(LifeCycleSavings), 1, 1) table(LifeCycleSavings$cl) LifeCycleSavings$wt <- rpois(n_life, lambda = 0.8) table(LifeCycleSavings$wt) lm_full <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings, weights = wt) LCS_sub <- subset(LifeCycleSavings, wt > 0) lm_sub <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LCS_sub, weights = wt) CR_full <- lapply(CR_types, function(x) vcovCR(lm_full, cluster = LifeCycleSavings$cl, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(lm_sub, cluster = LCS_sub$cl, type = x)) expect_equal(CR_full, CR_sub, check.attributes = FALSE) test_full <- lapply(CR_types, function(x) coef_test(lm_full, vcov = x, cluster = LifeCycleSavings$cl, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) test_sub <- lapply(CR_types, function(x) coef_test(lm_sub, vcov = x, cluster = LCS_sub$cl, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) expect_equal(test_full, test_sub, check.attributes = FALSE) dat_miss <- LifeCycleSavings miss_indicator <- sample.int(n_life, size = round(n_life / 5)) dat_miss$pop15[miss_indicator] <- NA dat_miss$cl[miss_indicator] <- NA with(dat_miss, table(wt, is.na(pop15))) lm_dropped <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = dat_miss, weights = wt) dat_complete <- subset(dat_miss, !is.na(pop15)) lm_complete <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = dat_complete, weights = wt) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, cluster = dat_miss$cl, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, cluster = dat_complete$cl, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, cluster = dat_miss$cl, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, cluster = dat_complete$cl, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("vcovCR errors when there is only one cluster.", { single_cluster_error_msg <- "Cluster-robust variance estimation will not work when the data only includes a single cluster." expect_error( vcovCR(lm_fit, cluster = dat$const, type = "CR0"), single_cluster_error_msg ) expect_error( conf_int(WLS_fit, vcov = "CR1", cluster = dat$const), single_cluster_error_msg ) expect_error( coef_test(lm_fit, vcov = "CR2", cluster = dat$const), single_cluster_error_msg ) expect_error( Wald_test(WLS_fit, constraints = constrain_zero(2:4), vcov = "CR3", cluster = dat$const), single_cluster_error_msg ) }) test_that("vcovCR works with intercept-only model and user-specified weights.", { lm_int <- lm(y ~ 1, data = dat) HC_un <- coef_test(lm_int, vcov="CR2", cluster=dat$row, test = "All") # Unweighted, HC-robust N <- nobs(lm_int) yi <- dat$y wi <- rep(1, N) W <- sum(wi) wi <- wi / W vi <- rep(1, N) V <- sum(vi) ei <- residuals_CS(lm_int) M <- sum(wi^2 * vi) ai <- 1 / sqrt(1 - 2 * wi + M / vi) V_hand <- sum(wi^2 * ai^2 * ei^2) pi_theta_pj <- diag(vi) - tcrossprod(rep(1,N), wi * vi) - tcrossprod(wi * vi, rep(1, N)) + M df <- M^2 / sum(tcrossprod(ai^2 * wi^2) * (pi_theta_pj^2)) expect_true(check_bread(lm_int, cluster = dat$row, y = dat$y)) expect_true(check_CR(lm_int, vcov = "CR2", cluster = dat$row)) expect_equal(sqrt(V_hand), HC_un$SE) expect_equal(df, HC_un$df_Satt) expect_equal(Inf, HC_un$df_z) expect_equal(N - 1, HC_un$df_t) # Unweighted, cluster-robust CR_un <- coef_test(lm_int, vcov="CR2", cluster=dat$cluster, test = "All") J <- nlevels(dat$cluster) w_j <- tapply(wi, dat$cluster, sum) e_j <- tapply(wi * ei, dat$cluster, sum) / w_j v_j <- tapply(wi^2 * vi, dat$cluster, sum) / w_j^2 a_j <- 1 / sqrt(1 - 2 * w_j + M / v_j) V_hand <- sum(w_j^2 * a_j^2 * e_j^2) pi_theta_pj <- diag(v_j) - tcrossprod(rep(1,J), w_j * v_j) - tcrossprod(w_j * v_j, rep(1, J)) + M df <- M^2 / sum(tcrossprod(a_j^2 * w_j^2) * (pi_theta_pj^2)) expect_true(check_bread(lm_int, cluster = dat$cluster, y = dat$y)) expect_true(check_CR(lm_int, vcov = "CR2", cluster = dat$cluster)) expect_equal(sqrt(V_hand), CR_un$SE) expect_equal(df, CR_un$df_Satt) expect_equal(Inf, CR_un$df_z) expect_equal(J - 1, CR_un$df_t) # Weighted, HC-robust WLS_int <- lm(y ~ 1, data = dat, weights = w) HC_wt <- coef_test(WLS_int, vcov="CR2", cluster=dat$row, test = "All") N <- nobs(WLS_int) yi <- dat$y wi <- WLS_int$weights W <- sum(wi) wi <- wi / W vi <- rep(1, N) V <- sum(vi) ei <- residuals_CS(WLS_int) M <- sum(wi^2 * vi) ai <- 1 / sqrt(1 - 2 * wi + M / vi) V_hand <- sum(wi^2 * ai^2 * ei^2) pi_theta_pj <- diag(vi) - tcrossprod(rep(1,N), wi * vi) - tcrossprod(wi * vi, rep(1, N)) + M df <- M^2 / sum(tcrossprod(ai^2 * wi^2) * (pi_theta_pj^2)) expect_true(check_bread(WLS_int, cluster = dat$row, y = dat$y)) expect_true(check_CR(WLS_int, vcov = "CR2", cluster = dat$row)) expect_equal(sqrt(V_hand), HC_wt$SE) expect_equal(df, HC_wt$df_Satt) expect_equal(Inf, HC_wt$df_z) expect_equal(N - 1, HC_wt$df_t) # Weighted, cluster-robust CR_wt <- coef_test(WLS_int, vcov="CR2", cluster=dat$cluster, test = "All") J <- nlevels(dat$cluster) w_j <- tapply(wi, dat$cluster, sum) e_j <- tapply(wi * ei, dat$cluster, sum) / w_j v_j <- tapply(wi^2 * vi, dat$cluster, sum) / w_j^2 a_j <- 1 / sqrt(1 - 2 * w_j + M / v_j) V_hand <- sum(w_j^2 * a_j^2 * e_j^2) pi_theta_pj <- diag(v_j) - tcrossprod(rep(1,J), w_j * v_j) - tcrossprod(w_j * v_j, rep(1, J)) + M df <- M^2 / sum(tcrossprod(a_j^2 * w_j^2) * (pi_theta_pj^2)) expect_true(check_bread(WLS_int, cluster = dat$cluster, y = dat$y)) expect_true(check_CR(WLS_int, vcov = "CR2", cluster = dat$cluster)) expect_equal(sqrt(V_hand), CR_wt$SE, tolerance = 10^-3) expect_equal(df, CR_wt$df_Satt, tolerance = 10^-3) expect_equal(Inf, CR_wt$df_z) expect_equal(J - 1, CR_wt$df_t) }) clubSandwich/tests/testthat/test_ignore_absorption.R0000644000176200001440000000631214630154052022571 0ustar liggesuserscontext("ignoring absorbed fixed effects") set.seed(20190513) skip_if_not_installed("plm") library(plm) data(MortalityRates) MV_Mortality <- subset(MortalityRates, cause=="Motor Vehicle" & state %in% 1:8) table(MV_Mortality$state) MV_Mortality$state_fac <- factor(MV_Mortality$state) # MV_Mortality$pop <- with(MV_Mortality, 1 + rbinom(nlevels(state_fac), size = 4, prob = 0.5)[state_fac]) summary(MV_Mortality$pop) MV_Mortality$pop_scale <- with(MV_Mortality, pop / mean(pop)) summary(MV_Mortality$pop_scale) # model specification specification <- mrate ~ 0 + legal + beertaxa + beerpercap + winepercap + factor(state) #----------------------- # unweighted #----------------------- ols_LSDV <- lm(specification, data = MV_Mortality) ols_within <- plm(update(specification, . ~ . - 0 - factor(state)), data = MV_Mortality, effect = "individual", index = c("state","year")) test_that("Unweighted lsdv and within estimators are equivalent", { lsdv <- coef_test(ols_LSDV, vcov = "CR2", cluster = MV_Mortality$state, coefs = 1:4, p_values = FALSE) wthn <- coef_test(ols_within, vcov = "CR2", p_values = FALSE) expect_equal(lsdv, wthn) }) #----------------------- # iv-weights #----------------------- wls_LSDV <- lm(specification, weights = pop_scale, data = MV_Mortality) MV_Mortality_full <- model.frame(lm(specification, weights = pop_scale, data = MV_Mortality)) U_mat <- model.matrix(update(specification, . ~ . - factor(state)), data = MV_Mortality_full) T_mat <- model.matrix(~ factor(state), data = MV_Mortality_full) w <- MV_Mortality_full$"(weights)" state <- MV_Mortality_full$"factor(state)" U_absorb <- residuals(stats:::lm.wfit(x = T_mat, y = U_mat, w = w))[,-31] Y_absorb <- residuals(stats:::lm.wfit(x = T_mat, y = MV_Mortality_full$mrate, w = w)) wls_within <- lm(Y_absorb ~ 0 + U_absorb, weights = w) test_that("Inverse-variance weighted lsdv and within estimators are equivalent.", { lsdv <- coef_test(wls_LSDV, vcov = "CR2", cluster = MV_Mortality$state, inverse_var = TRUE, p_values = FALSE)[1:4,] wthn <- coef_test(wls_within, vcov = "CR2", cluster = state, inverse_var = TRUE, p_values = FALSE)[1:4,] expect_equal(lsdv$beta, wthn$beta, check.attributes = FALSE, tolerance = 10^-5) expect_equal(lsdv$SE, wthn$SE, check.attributes = FALSE, tolerance = 10^-2) expect_equal(lsdv$tstat, wthn$tstat, check.attributes = FALSE, tolerance = 10^-2) expect_equal(lsdv$df_Satt, wthn$df_Satt, check.attributes = FALSE, tolerance = 10^-2) }) #----------------------- # p-weights #----------------------- test_that("Probability-weighted lsdv and within estimators are not necessarily equivalent.", { lsdv <- coef_test(wls_LSDV, vcov = "CR2", cluster = MV_Mortality$state, inverse_var = FALSE, coefs = 1:4, p_values = FALSE) wthn <- coef_test(wls_within, vcov = "CR2", cluster = state, inverse_var = FALSE, p_values = FALSE) expect_equal(lsdv$beta, wthn$beta, check.attributes = FALSE, tolerance = 10^-5) expect_equal(lsdv$SE, wthn$SE, check.attributes = FALSE, tolerance = 10^-2) expect_equal(lsdv$tstat, wthn$tstat, check.attributes = FALSE, tolerance = 10^-2) expect_equal(lsdv$df_Satt, wthn$df_Satt, check.attributes = FALSE, tolerance = 10^-2) }) clubSandwich/tests/testthat/test_ivreg_ivreg.R0000644000176200001440000002773714630154052021374 0ustar liggesusers############################# context("ivreg::ivreg objects") set.seed(20190513) skip_if_not_installed("ivreg") library(ivreg, quietly=TRUE) data("CigarettesSW", package = "AER") Cigs <- within(CigarettesSW, { rprice <- price/cpi rincome <- income/population/cpi tdiff <- (taxs - tax)/cpi }) CR_types <- paste0("CR",0:4) obj_un <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs) obj_wt <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, weights = population) X <- model.matrix(obj_wt, component = "regressors") Z <- model.matrix(obj_wt, component = "instruments") y <- log(CigarettesSW$packs) w <- weights(obj_wt) test_that("Basic calculations from ivreg agree for unweighted model.", { XZ <- model.matrix(obj_un, component = "projected") ZtZ_inv <- chol2inv(chol(t(Z) %*% Z)) XZ_check <- Z %*% ZtZ_inv %*% t(Z) %*% X expect_equal(XZ, XZ_check, check.attributes=FALSE) expect_equal(coef(obj_un), lm.fit(XZ, y)$coefficients) expect_equal (bread(obj_un), chol2inv(chol(t(XZ) %*% XZ)) * nobs(obj_un), check.attributes=FALSE) hii <- diag(XZ %*% chol2inv(chol(t(XZ) %*% XZ)) %*% t(XZ)) expect_equal(hatvalues(obj_un, type = "stage2"), hii) r <- as.vector(y - X %*% coef(obj_un)) expect_equal(r, as.vector(residuals_CS(obj_un))) }) test_that("Basic calculations from ivreg agree for weighted model.", { XZ <- model.matrix(obj_wt, component = "projected") ZwZ_inv <- chol2inv(chol(t(Z) %*% (w * Z))) XZ_check <- Z %*% ZwZ_inv %*% t(Z) %*% (w * X) expect_equal(XZ, XZ_check, check.attributes=FALSE) expect_equal(coef(obj_wt), lm.wfit(XZ, y, w)$coefficients) expect_equal(bread(obj_wt), chol2inv(chol(t(XZ) %*% (w * XZ))) * nobs(obj_wt), check.attributes=FALSE) hii <- diag(X%*% chol2inv(chol(t(XZ) %*% (w * XZ))) %*% t(w * XZ)) expect_false(all(hatvalues(obj_wt) == hii)) # does not agree because hatvalues doesn't work with weighting r <- as.vector(y - X %*% coef(obj_wt)) expect_equal(r, as.vector(residuals_CS(obj_wt))) }) test_that("bread works", { expect_true(check_bread(obj_un, cluster = Cigs$state, y = log(Cigs$packs))) tsls_vcov <- bread(obj_un) * summary(obj_un)$sigma^2 / v_scale(obj_un) expect_equal(vcov(obj_un), tsls_vcov) expect_true(check_bread(obj_wt, cluster = Cigs$state, y = log(Cigs$packs))) wtsls_vcov <- bread(obj_wt) * summary(obj_wt)$sigma^2 / v_scale(obj_wt) expect_equal(vcov(obj_wt), wtsls_vcov) }) test_that("vcovCR options don't matter for CR0", { expect_error(vcovCR(obj_un, type = "CR0")) CR0 <- vcovCR(obj_un, cluster = Cigs$state, type = "CR0") expect_output(print(CR0)) attr(CR0, "target") <- NULL attr(CR0, "inverse_var") <- NULL CR0_A <- vcovCR(obj_un, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population) attr(CR0_A, "target") <- NULL attr(CR0_A, "inverse_var") <- NULL expect_identical(CR0_A, CR0) CR0_B <- vcovCR(obj_un, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = FALSE) attr(CR0_B, "target") <- NULL attr(CR0_B, "inverse_var") <- NULL expect_identical(CR0_A, CR0) expect_error(vcovCR(obj_un, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = TRUE)) wCR0 <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR0") attr(wCR0, "target") <- NULL attr(wCR0, "inverse_var") <- NULL wCR0_A <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population) attr(wCR0_A, "target") <- NULL attr(wCR0_A, "inverse_var") <- NULL expect_identical(wCR0_A, wCR0) wCR0_B <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = FALSE) attr(wCR0_B, "target") <- NULL attr(wCR0_B, "inverse_var") <- NULL expect_identical(wCR0_B, wCR0) expect_error(vcovCR(obj_wt, cluster = Cigs$state, type = "CR0", target = 1 / Cigs$population, inverse_var = TRUE)) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(obj_un, cluster = Cigs$state, type = "CR2") expect_equal(vcovCR(obj_un, cluster = Cigs$state, type = "CR2", target = rep(1, nobs(obj_un))), CR2_iv) expect_false(identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR2", target = 1 / Cigs$population), CR2_iv)) wCR2_id <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR2") expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR2", inverse_var = FALSE), wCR2_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR2", target = rep(1, nobs(obj_un))), wCR2_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR2", target = rep(1, nobs(obj_un)), inverse_var = FALSE), wCR2_id) }) test_that("vcovCR options work for CR4", { CR4_not <- vcovCR(obj_un, cluster = Cigs$state, type = "CR4") expect_identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_un))), CR4_not) expect_identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_un)), inverse_var = FALSE), CR4_not) expect_false(identical(vcovCR(obj_un, cluster = Cigs$state, type = "CR4", target = 1 / Cigs$population), CR4_not)) wCR4_id <- vcovCR(obj_wt, cluster = Cigs$state, type = "CR4") expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR4", inverse_var = FALSE), wCR4_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_wt))), wCR4_id) expect_identical(vcovCR(obj_wt, cluster = Cigs$state, type = "CR4", target = rep(1, nobs(obj_wt)), inverse_var = FALSE), wCR4_id) }) test_that("CR2 is target-unbiased", { expect_true(check_CR(obj_un, vcov = "CR2", cluster = Cigs$state)) expect_true(check_CR(obj_wt, vcov = "CR2", cluster = Cigs$state)) }) test_that("CR4 is target-unbiased", { skip("Need to understand target-unbiasedness for ivreg objects.") expect_true(check_CR(obj_un, vcov = "CR4", cluster = Cigs$state)) expect_true(check_CR(obj_wt, vcov = "CR4", cluster = Cigs$state)) }) test_that("vcovCR is equivalent to vcovHC (with HC0 or HC1) when clusters are all of size 1", { library(sandwich, quietly=TRUE) CR0 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR0") expect_equal(vcovHC(obj_un, type = "HC0"), as.matrix(CR0)) CR1 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR1S") expect_equal(vcovHC(obj_un, type = "HC1"), as.matrix(CR1)) CR2 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR2") expect_false(all(vcovHC(obj_un, type = "HC2") == as.matrix(CR2))) CR3 <- vcovCR(obj_un, cluster = 1:nobs(obj_un), type = "CR3") expect_false(all(vcovHC(obj_un, type = "HC3") == as.matrix(CR3))) }) test_that("Order doesn't matter.",{ check_sort_order(obj_wt, Cigs, "state") }) # Clustering variable must have length equal to the number of rows in the data used to fit obj. test_that("clubSandwich works with dropped observations", { dat_miss <- Cigs dat_miss$rincome[sample.int(nrow(Cigs), size = round(nrow(Cigs) / 10))] <- NA iv_dropped <- update(obj_un, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(rincome)) iv_complete <- update(obj_un, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(iv_dropped, cluster = dat_miss$state, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(iv_complete, cluster = dat_complete$state, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(iv_dropped, vcov = x, cluster = dat_miss$state, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(iv_complete, vcov = x, cluster = dat_complete$state, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("weight scale doesn't matter", { iv_fit_w <- update(obj_un, weights = rep(4, nobs(obj_un))) unweighted_fit <- lapply(CR_types, function(x) vcovCR(obj_un, cluster = Cigs$state, type = x)) weighted_fit <- lapply(CR_types, function(x) vcovCR(iv_fit_w, cluster = Cigs$state, type = x)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix), tol = 5 * 10^-7) target <- 1 + rpois(nrow(Cigs), lambda = 8) unweighted_fit <- lapply(CR_types, function(x) vcovCR(obj_un, cluster = Cigs$state, type = x, target = target)) weighted_fit <- lapply(CR_types, function(x) vcovCR(iv_fit_w, cluster = Cigs$state, type = x, target = target * 15)) expect_equal(lapply(unweighted_fit, as.matrix), lapply(weighted_fit, as.matrix), tol = 5 * 10^-7) }) test_that("clubSandwich works with weights of zero.", { n_Cigs <- nrow(Cigs) Cigs$awt <- rpois(n_Cigs, lambda = 1.4) table(Cigs$awt) iv_full <- update(obj_un, weights = awt) Cigs_sub <- subset(Cigs, awt > 0) iv_sub <- update(iv_full, data = Cigs_sub) CR_full <- lapply(CR_types, function(x) vcovCR(iv_full, cluster = Cigs$state, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(iv_sub, cluster = Cigs_sub$state, type = x)) expect_equal(CR_full, CR_sub, check.attributes = FALSE) test_full <- lapply(CR_types, function(x) coef_test(iv_full, vcov = x, cluster = Cigs$state, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) test_sub <- lapply(CR_types, function(x) coef_test(iv_sub, vcov = x, cluster = Cigs_sub$state, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) expect_equal(test_full, test_sub, check.attributes = FALSE) dat_miss <- Cigs miss_indicator <- sample.int(n_Cigs, size = round(n_Cigs / 10)) dat_miss$rincome[miss_indicator] <- NA with(dat_miss, table(awt, is.na(rincome))) iv_dropped <- update(iv_full, data = dat_miss) dat_complete <- subset(dat_miss, !is.na(rincome)) iv_complete <- update(iv_full, data = dat_complete) CR_drop <- lapply(CR_types, function(x) vcovCR(iv_dropped, cluster = dat_miss$state, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(iv_complete, cluster = dat_complete$state, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(iv_dropped, vcov = x, cluster = dat_miss$state, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(iv_complete, vcov = x, cluster = dat_complete$state, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) #------------------------------------------------------------------------------- # Other estimation methods ols_un <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, method = "OLS") ols_wt <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, weights = population, method = "OLS") mom_un <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, method = "M") mom_wt <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, weights = population, method = "M") rob_un <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, method = "MM") rob_wt <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs, weights = population, method = "MM") test_that("vcovCR does not currently support ivreg models estimated using method = 'M' or method = 'MM'", { expect_error(vcovCR(mom_un, cluster = Cigs$state, type = "CR2")) expect_error(vcovCR(mom_wt, cluster = Cigs$state, type = "CR2")) expect_error(vcovCR(rob_un, cluster = Cigs$state, type = "CR2")) expect_error(vcovCR(rob_wt, cluster = Cigs$state, type = "CR2")) }) clubSandwich/tests/testthat/test_plm-ID-variables.R0000644000176200001440000003556114630154052022106 0ustar liggesuserscontext("plm objects - ID variables") set.seed(20190513) skip_if_not_installed("plm") library(plm, quietly=TRUE) data("Produc", package = "plm") Produc <- Produc[sample(nrow(Produc)),] Produc$cluster <- sample(LETTERS[1:10], size = nrow(Produc), replace=TRUE) plm_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = "state", effect = "individual", model = "within") lm_individual <- lm(log(gsp) ~ 0 + state + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) individual_names <- names(coef(plm_individual)) individual_index <- names(coef(lm_individual)) %in% individual_names lm_CR0 <- vcovCR(lm_individual, cluster = Produc$state, type = "CR0")[individual_index,individual_index] lm_CR1 <- vcovCR(lm_individual, cluster = Produc$state, type = "CR1")[individual_index,individual_index] lm_CR2 <- vcovCR(lm_individual, cluster = Produc$state, type = "CR2")[individual_index,individual_index] plm_CR0 <- vcovCR(plm_individual, type="CR0")[individual_names,individual_names] test_that("individual effects agree with lm under automatic clustering", { plm_CR1 <- vcovCR(plm_individual, type="CR1")[individual_names,individual_names] plm_CR2 <- vcovCR(plm_individual, type="CR2")[individual_names,individual_names] expect_equal(plm_CR0, lm_CR0) expect_equal(plm_CR1, lm_CR1) expect_equal(plm_CR2, lm_CR2) }) test_that("individual effects agree with lm under explicit clustering", { plm_CR1 <- vcovCR(plm_individual, cluster = Produc$state, type="CR1")[individual_names,individual_names] plm_CR2 <- vcovCR(plm_individual, cluster = Produc$state, type="CR2")[individual_names,individual_names] expect_equal(plm_CR1, lm_CR1) expect_equal(plm_CR2, lm_CR2) }) test_that("individual effects agree with lm under random clustering", { lm_CR1 <- vcovCR(lm_individual, cluster = Produc$cluster, type = "CR1")[individual_index,individual_index] lm_CR2 <- vcovCR(lm_individual, cluster = Produc$cluster, type = "CR2")[individual_index,individual_index] plm_CR1 <- vcovCR(plm_individual, cluster = Produc$cluster, type="CR1")[individual_names,individual_names] plm_CR2 <- vcovCR(plm_individual, cluster = Produc$cluster, type="CR2")[individual_names,individual_names] expect_equal(plm_CR1, lm_CR1) expect_equal(plm_CR2, lm_CR2) }) test_that("CR0 and CR1S agree with arellano vcov", { expect_equal(vcovHC(plm_individual, method="arellano", type = "HC0", cluster = "group"), as.matrix(plm_CR0), check.attributes = FALSE) expect_equal(vcovHC(plm_individual, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR1S")), check.attributes = FALSE) }) test_that("plm works for Yuki Takahashi's reprex.",{ N <- 100 id <- rep(1:N, 2) gid <- rep(1:(N/2), 4) Trt <- rep(c(0,1), each = N) a <- rep(rnorm(N, mean=0, sd=0.005), 2) gp <- rep(rnorm(N / 2, mean=0, sd=0.0005), 4) u <- rnorm(N * 2, mean=0, sd=0.05) Ylatent <- -0.05 * Trt + gp + a + u Data <- data.frame( Y = ifelse(Ylatent > 0, 1, 0), id, gid, Trt ) fe_fit <- plm(formula = Y ~ Trt, data = Data, model = "within", index = "id", effect = "individual") implicit <- vcovCR(fe_fit, type = "CR2") explicit <- vcovCR(fe_fit, cluster=Data$id, type = "CR2") expect_equal(implicit, explicit) expect_s3_class(vcovCR(fe_fit, cluster=Data$gid, type = "CR2"), "vcovCR") }) test_that("Clustering works for various ways of specifying unit and time indices in plm.", { data("Grunfeld", package = "plm") Grunfeld$cluster <- sample(LETTERS[1:10], size = nrow(Grunfeld), replace=TRUE) rearrange <- mapply(function(s,b) seq(s, nrow(Grunfeld), b), 1:10, 11:20) rearrange <- unique(unlist(rearrange)) rearrange <- c(rearrange, setdiff(1:200, rearrange)) Grunfeld_scramble <- Grunfeld[rearrange,] Grunfeld_pdata <- pdata.frame(Grunfeld_scramble, index = c("firm","year")) plm_pdata <- plm(inv ~ value + capital, data = Grunfeld_pdata, model="within") plm_numeric <- plm(inv ~ value + capital, data = Grunfeld, index = 10, model="within") plm_noindex <- plm(inv ~ value + capital, data = Grunfeld_scramble, model="within") plm_oneindex <- plm(inv ~ value + capital, data = Grunfeld_scramble, index = "firm", model="within") plm_twoindex <- plm(inv ~ value + capital, data = Grunfeld_scramble, index = c("firm","year"), model="within") CR_types <- paste0("CR",0:3) # auto clustering vcovCRs <- function(model, types) lapply(types, function(x) vcovCR(model, type = x)) CR_pdata <- vcovCRs(plm_pdata, CR_types) expect_equivalent(CR_pdata, vcovCRs(plm_numeric, CR_types)) expect_equivalent(CR_pdata, vcovCRs(plm_noindex, CR_types)) expect_equivalent(CR_pdata, vcovCRs(plm_oneindex, CR_types)) expect_equivalent(CR_pdata, vcovCRs(plm_twoindex, CR_types)) # manual clustering on firm vcovCRs <- function(model, types, cluster) lapply(types, function(x) vcovCR(model, type = x, cluster = cluster)) expect_equivalent(CR_pdata, vcovCRs(plm_numeric, CR_types, cluster = Grunfeld$firm)) expect_equivalent(CR_pdata, vcovCRs(plm_noindex, CR_types, cluster = Grunfeld_scramble$firm)) expect_equivalent(CR_pdata, vcovCRs(plm_oneindex, CR_types, cluster = Grunfeld_scramble$firm)) expect_equivalent(CR_pdata, vcovCRs(plm_twoindex, CR_types, cluster = Grunfeld_scramble$firm)) # manual clustering on arbitrary id CR_pdata <- vcovCRs(plm_pdata, CR_types, cluster = Grunfeld_pdata$cluster) expect_equivalent(CR_pdata, vcovCRs(plm_numeric, CR_types, cluster = Grunfeld$cluster)) expect_equivalent(CR_pdata, vcovCRs(plm_noindex, CR_types, cluster = Grunfeld_scramble$cluster)) expect_equivalent(CR_pdata, vcovCRs(plm_oneindex, CR_types, cluster = Grunfeld_scramble$cluster)) expect_equivalent(CR_pdata, vcovCRs(plm_twoindex, CR_types, cluster = Grunfeld_scramble$cluster)) }) test_that("findCluster works for plm objects.", { pool_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "individual", model = "pooling") index <- attr(model.frame(pool_individual),"index") expect_equal(findCluster.plm(pool_individual), index$state) expect_equal(findCluster.plm(pool_individual, "individual"), index$state) expect_equal(findCluster.plm(pool_individual, "time"), index$year) expect_equal(findCluster.plm(pool_individual, "group"), index$region) expect_equal(findCluster.plm(pool_individual, "state"), index$state) expect_equal(findCluster.plm(pool_individual, "year"), index$year) expect_equal(findCluster.plm(pool_individual, "region"), index$region) expect_equal(findCluster.plm(pool_individual, Produc$region), index$region) within_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "individual", model = "within") expect_equal(findCluster.plm(within_individual), index$state) expect_equal(findCluster.plm(within_individual, "individual"), index$state) expect_equal(findCluster.plm(within_individual, "time"), index$year) expect_equal(findCluster.plm(within_individual, "group"), index$region) expect_equal(findCluster.plm(within_individual, "state"), index$state) expect_equal(findCluster.plm(within_individual, "year"), index$year) expect_equal(findCluster.plm(within_individual, "region"), index$region) expect_equal(findCluster.plm(within_individual, Produc$region), index$region) between_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "individual", model = "between") expect_equal(findCluster.plm(between_individual), index$state) expect_equal(findCluster.plm(between_individual, "individual"), index$state) expect_equal(findCluster.plm(between_individual, "time"), index$year) expect_equal(findCluster.plm(between_individual, "group"), index$region) expect_equal(findCluster.plm(between_individual, "state"), index$state) expect_equal(findCluster.plm(between_individual, "year"), index$year) expect_equal(findCluster.plm(between_individual, "region"), index$region) expect_equal(findCluster.plm(between_individual, Produc$region), index$region) RE_individual <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "individual", model = "random") expect_equal(findCluster.plm(RE_individual), index$state) expect_equal(findCluster.plm(RE_individual, "individual"), index$state) expect_error(findCluster.plm(RE_individual, "time")) expect_equal(findCluster.plm(RE_individual, "group"), index$region) expect_equal(findCluster.plm(RE_individual, "state"), index$state) expect_error(findCluster.plm(RE_individual, "year")) expect_equal(findCluster.plm(RE_individual, "region"), index$region) expect_equal(findCluster.plm(RE_individual, Produc$region), index$region) pool_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "time", model = "pooling") expect_equal(findCluster.plm(pool_time), index$year) expect_equal(findCluster.plm(pool_time, "individual"), index$state) expect_equal(findCluster.plm(pool_time, "time"), index$year) expect_equal(findCluster.plm(pool_time, "group"), index$region) expect_equal(findCluster.plm(pool_time, "state"), index$state) expect_equal(findCluster.plm(pool_time, "year"), index$year) expect_equal(findCluster.plm(pool_time, "region"), index$region) expect_equal(findCluster.plm(pool_time, Produc$region), index$region) within_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "time", model = "within") expect_equal(findCluster.plm(within_time), index$year) expect_equal(findCluster.plm(within_time, "individual"), index$state) expect_equal(findCluster.plm(within_time, "time"), index$year) expect_equal(findCluster.plm(within_time, "group"), index$region) expect_equal(findCluster.plm(within_time, "state"), index$state) expect_equal(findCluster.plm(within_time, "year"), index$year) expect_equal(findCluster.plm(within_time, "region"), index$region) expect_equal(findCluster.plm(within_time, Produc$region), index$region) between_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "time", model = "between") expect_equal(findCluster.plm(between_time), index$year) expect_equal(findCluster.plm(between_time, "individual"), index$state) expect_equal(findCluster.plm(between_time, "time"), index$year) expect_equal(findCluster.plm(between_time, "group"), index$region) expect_equal(findCluster.plm(between_time, "state"), index$state) expect_equal(findCluster.plm(between_time, "year"), index$year) expect_equal(findCluster.plm(between_time, "region"), index$region) expect_equal(findCluster.plm(between_time, Produc$region), index$region) RE_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "time", model = "random") expect_equal(findCluster.plm(RE_time), index$year) expect_error(findCluster.plm(RE_time, "individual")) expect_equal(findCluster.plm(RE_time, "time"), index$year) expect_error(findCluster.plm(RE_time, "group")) expect_error(findCluster.plm(RE_time, "state")) expect_equal(findCluster.plm(RE_time, "year"), index$year) expect_error(findCluster.plm(RE_time, "region")) expect_error(findCluster.plm(RE_time, Produc$region)) pool_twoways <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "twoways", model = "pooling") expect_error(findCluster.plm(pool_twoways)) expect_equal(findCluster.plm(pool_twoways, "individual"), index$state) expect_equal(findCluster.plm(pool_twoways, "time"), index$year) expect_equal(findCluster.plm(pool_twoways, "group"), index$region) expect_equal(findCluster.plm(pool_twoways, "state"), index$state) expect_equal(findCluster.plm(pool_twoways, "year"), index$year) expect_equal(findCluster.plm(pool_twoways, "region"), index$region) expect_equal(findCluster.plm(pool_twoways, Produc$region), index$region) within_twoways <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "twoways", model = "within") expect_error(findCluster.plm(within_twoways)) expect_equal(findCluster.plm(within_twoways, "individual"), index$state) expect_equal(findCluster.plm(within_twoways, "time"), index$year) expect_equal(findCluster.plm(within_twoways, "group"), index$region) expect_equal(findCluster.plm(within_twoways, "state"), index$state) expect_equal(findCluster.plm(within_twoways, "year"), index$year) expect_equal(findCluster.plm(within_twoways, "region"), index$region) expect_equal(findCluster.plm(within_twoways, Produc$region), index$region) RE_twoways <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "twoways", model = "random") expect_error(findCluster.plm(RE_twoways)) expect_error(findCluster.plm(RE_twoways, "individual")) expect_error(findCluster.plm(RE_twoways, "time")) expect_error(findCluster.plm(RE_twoways, "group")) expect_error(findCluster.plm(RE_twoways, "state")) expect_error(findCluster.plm(RE_twoways, "year")) expect_error(findCluster.plm(RE_twoways, "region")) expect_error(findCluster.plm(RE_twoways, Produc$region)) RE_nested <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "nested", model = "random") expect_equal(findCluster.plm(RE_nested), index$region) expect_error(findCluster.plm(RE_nested, "individual")) expect_error(findCluster.plm(RE_nested, "time")) expect_equal(findCluster.plm(RE_nested, "group"), index$region) expect_error(findCluster.plm(RE_nested, "state")) expect_error(findCluster.plm(RE_nested, "year")) expect_equal(findCluster.plm(RE_nested, "region"), index$region) expect_equal(findCluster.plm(RE_nested, Produc$region), index$region) }) clubSandwich/tests/testthat/test_linear_contrast.R0000644000176200001440000002124414630154052022236 0ustar liggesusersset.seed(20210110) skip_if_not_installed("carData") # Duncan example data(Duncan, package = "carData") Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) Duncan_int <- lm(prestige ~ type * (income + education), data=Duncan) coefs_int <- coef(Duncan_int) coef_names_int <- names(coefs_int) Duncan_int_CR2 <- vcovCR(Duncan_int, type = "CR2", cluster = Duncan$cluster) Duncan_sep <- lm(prestige ~ 0 + type + type:(income + education), data=Duncan) coefs_sep <- coef(Duncan_sep) coef_names_sep <- names(coefs_sep) Duncan_sep_CR2 <- vcovCR(Duncan_sep, type = "CR2", cluster = Duncan$cluster) # STAR example skip_if_not_installed("AER") data(STAR, package = "AER") levels(STAR$stark)[3] <- "aide" levels(STAR$schoolk)[1] <- "urban" STAR <- subset(STAR, !is.na(schoolidk), select = c(schoolidk, schoolk, stark, gender, ethnicity, math1, lunchk)) lm_urbanicity <- lm(math1 ~ schoolk * stark + gender + ethnicity + lunchk, data = STAR) CRs <- paste0("CR", 0:4) test_that("vcov arguments work", { VCR <- lapply(CRs, function(t) vcovCR(Duncan_sep, type = t, cluster = Duncan$cluster)) CI_A <- lapply(VCR, function(v) linear_contrast(Duncan_sep, vcov = v, cluster = Duncan$cluster, contrast = constrain_pairwise(1:3), level = .98)) CI_B <- lapply(CRs, function(t) linear_contrast(Duncan_sep, vcov = t, cluster = Duncan$cluster, contrast = constrain_pairwise(1:3), level = .98)) expect_equal(CI_A, CI_B, check.attributes = FALSE) }) test_that("constrain_() functions work.", { # Not worrying about CR4 here CI_A <- lapply(CRs[1:4], function(t) linear_contrast(Duncan_sep, vcov = t, cluster = Duncan$cluster, contrast = constrain_pairwise(1:3)) ) CI_B <- lapply(CRs[1:4], function(t) linear_contrast(Duncan_int, vcov = t, cluster = Duncan$cluster, contrast = constrain_pairwise(2:3, with_zero = TRUE)) ) CI_A <- lapply(CI_A, subset, select = -Coef) CI_B <- lapply(CI_B, subset, select = -Coef) expect_equal(CI_A, CI_B, check.attributes = FALSE) }) test_that("linear_contrast() works with lists.", { CIs <- linear_contrast(lm_urbanicity, vcov = "CR2", cluster = STAR$schoolidk, contrast = list( A = constrain_zero(2:3), B = constrain_pairwise(2:3, with_zero = TRUE), C = constrain_equal("ethnicity", reg_ex = TRUE), D = constrain_pairwise("ethnicity", reg_ex = TRUE) )) CI_A <- as.data.frame(subset(CIs, grepl("A\\.", Coef), select = -Coef)) CI_B <- as.data.frame(subset(CIs, grepl("B\\.[a-z]+$", Coef), select = -Coef)) expect_equal(CI_A, CI_B, check.attributes = FALSE) CI_C <- as.data.frame(subset(CIs, grepl("C\\.", Coef), select = -Coef)) CI_D <- as.data.frame(subset(CIs, grepl("D\\..+ethnicityafam$", Coef), select = -Coef)) expect_equal(CI_C, CI_D, check.attributes = FALSE) }) test_that("printing works", { CIs <- linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE)) expect_output(print(CIs)) CIs <- linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), p_values = TRUE) expect_output(x <- print(CIs)) expect_true(all(c("p-value","Sig.") %in% names(x))) }) test_that("level checks work", { expect_error(linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), level = -0.01)) expect_error(linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), level = 95)) expect_output(print( linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), level = runif(1)) )) }) test_that("CI boundaries are ordered", { lev <- runif(1) CI_z <- linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), test = "z", level = lev) CI_t <- linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), test = "naive-t", level = lev) CI_Satt <- linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), test = "Satterthwaite", level = lev) expect_true(all(CI_t$CI_L < CI_z$CI_L)) expect_true(all(CI_t$CI_U > CI_z$CI_U)) expect_true(all(CI_Satt$CI_L < CI_z$CI_L)) expect_true(all(CI_Satt$CI_U > CI_z$CI_U)) }) test_that("linear_contrast() is consistent with Wald_test()", { skip_on_cran() lev <- runif(1) CIs <- lapply(CRs, function(v) linear_contrast(lm_urbanicity, vcov = v, cluster = STAR$schoolidk, contrasts = list( A = constrain_zero("ethnicity", reg_ex = TRUE), B = constrain_equal("ethnicity", reg_ex = TRUE) ), test = "Satterthwaite", level = lev, p_values = TRUE)) Wald_tests <- lapply(CRs, function(v) Wald_test(lm_urbanicity, vcov = v, cluster = STAR$schoolidk, constraints = constrain_pairwise("ethnicity", reg_ex = TRUE, with_zero = TRUE), test = "HTZ", tidy = TRUE)) CI_pvals <- lapply(CIs, function(x) x$p_val) Wald_pvals <- lapply(Wald_tests, function(x) x$p_val[1:7]) expect_equal(CI_pvals, Wald_pvals, tolerance = 1e-6) }) test_that("linear_contrast() has informative error messages.", { expect_error( linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), test = "all") ) expect_error( linear_contrast(Duncan_sep, vcov = "CR0", cluster = Duncan$cluster, constrain_pairwise(":education", reg_ex = TRUE), test = "saddlepoint") ) }) test_that("linear_contrast() works with scalar (length-1) contrasts.", { lm_int <- lm(math1 ~ 1, data = STAR) x0 <- linear_contrast(lm_int, vcov = "CR0", cluster = STAR$schoolidk, contrasts = 1) expect_s3_class(x0, "conf_int_clubSandwich") x2 <- linear_contrast(lm_int, vcov = "CR2", cluster = STAR$schoolidk, contrasts = 1) expect_s3_class(x2, "conf_int_clubSandwich") y0 <- linear_contrast(lm_int, vcov = "CR0", cluster = STAR$schoolidk, contrasts = matrix(1)) y0$Coef <- row.names(y0) <- "Contrast" expect_equal(x0, y0) y2 <- linear_contrast(lm_int, vcov = "CR2", cluster = STAR$schoolidk, contrasts = 1) y2$Coef <- row.names(y2) <- "Contrast" expect_equal(x2, y2) STAR$wt <- 1L wls_int <- lm(math1 ~ 1, weights = wt, data = STAR) z0 <- linear_contrast(wls_int, vcov = "CR0", cluster = STAR$schoolidk, contrasts = 1) expect_s3_class(z0, "conf_int_clubSandwich") z2 <- linear_contrast(wls_int, vcov = "CR2", cluster = STAR$schoolidk, contrasts = 1) expect_s3_class(z2, "conf_int_clubSandwich") }) test_that("linear_contrast() works with scalar (length-1) contrasts in metafor.", { skip_if_not_installed("metafor") suppressPackageStartupMessages(library(metafor)) dat <- dat.bangertdrowns2004 res_uni <- rma(yi, vi, weights = 1, data=dat) x0 <- linear_contrast(res_uni, vcov = "CR0", cluster = dat$id, contrasts = 1) expect_s3_class(x0, "conf_int_clubSandwich") y0 <- linear_contrast(res_uni, vcov = "CR0", cluster = dat$id, contrasts = matrix(1)) y0$Coef <- row.names(y0) <- "Contrast" expect_equal(x0, y0) x2 <- linear_contrast(res_uni, vcov = "CR2", cluster = dat$id, contrasts = 1) expect_s3_class(x2, "conf_int_clubSandwich") y2 <- linear_contrast(res_uni, vcov = "CR2", cluster = dat$id, contrasts = 1) y2$Coef <- row.names(y2) <- "Contrast" expect_equal(x2, y2) }) clubSandwich/tests/testthat/test_intercept_formulas.R0000644000176200001440000000433414630154052022755 0ustar liggesuserscontext("population mean estimation") set.seed(20190513) m <- 14 icc <- 0.2 mu <- 5 size <- 2 nj <- 1 + rnbinom(m, size = size, mu = mu) group <- factor(rep(LETTERS[1:m], nj)) N <- sum(nj) Y <- rnorm(m, sd = sqrt(icc))[group] + rnorm(N, sd = sqrt(1 - icc)) y_bar <- tapply(Y, group, mean) lm_fit <- lm(Y ~ 1) test_that("CR0 and df agree with formulas", { CR0 <- coef_test(lm_fit, vcov = "CR0", cluster = group, test = "Satterthwaite") VCR0_f <- sum(nj^2 * (y_bar - mean(Y))^2) / sum(nj)^2 df0_f <- (N^2 - sum(nj^2))^2 / (N^2 * sum(nj^2) - 2 * N * sum(nj^3) + sum(nj^2)^2) expect_equal(as.numeric(CR0$SE), sqrt(VCR0_f)) expect_equal(CR0$df, df0_f) }) test_that("CR1 and df agree with formulas", { CR1 <- coef_test(lm_fit, vcov = "CR1", cluster = group, test = "Satterthwaite") VCR1_f <- (m / (m - 1)) * sum(nj^2 * (y_bar - mean(Y))^2) / sum(nj)^2 df1_f <- (N^2 - sum(nj^2))^2 / (N^2 * sum(nj^2) - 2 * N * sum(nj^3) + sum(nj^2)^2) expect_equal(as.numeric(CR1$SE), sqrt(VCR1_f)) expect_equal(CR1$df, df1_f) }) test_that("CR2 and df agree with formulas", { CR2 <- coef_test(lm_fit, vcov = "CR2", cluster = group, test = "Satterthwaite") VCR2_f <- sum(nj^2 * (y_bar - mean(Y))^2 / (1 - nj / N)) / sum(nj)^2 df2_f <- N^2 / (N^2 * sum(nj^2 / (N - nj)^2) - 2 * N * sum(nj^3 / (N - nj)^2) + sum(nj^2 / (N - nj))^2) expect_equal(as.numeric(CR2$SE), sqrt(VCR2_f)) expect_equal(CR2$df, df2_f) }) test_that("CR3 agrees with formula", { CR3 <- coef_test(lm_fit, vcov = "CR3", cluster = group, test = "Satterthwaite") VCR3_f <- sum(nj^2 * (y_bar - mean(Y))^2 / (1 - nj / N)^2) / sum(nj)^2 # df2_f <- N^2 / (N^2 * sum(nj^2 / (N - nj)^2) - 2 * N * sum(nj^3 / (N - nj)^2) + sum(nj^2 / (N - nj))^2) expect_equal(as.numeric(CR3$SE), sqrt(VCR3_f)) # expect_equal(CR2$df, df2_f) }) test_that("CR4 and df agree with formulas", { CR4 <- coef_test(lm_fit, vcov = "CR4", cluster = group, test = "Satterthwaite") VCR4_f <- sum(nj^2 * (y_bar - mean(Y))^2 / (1 - nj / N)) / sum(nj)^2 df4_f <- N^2 / (N^2 * sum(nj^2 / (N - nj)^2) - 2 * N * sum(nj^3 / (N - nj)^2) + sum(nj^2 / (N - nj))^2) expect_equal(as.numeric(CR4$SE), sqrt(VCR4_f)) expect_equal(CR4$df, df4_f) }) clubSandwich/tests/testthat/test_rma-uni.R0000644000176200001440000003736714630154052020434 0ustar liggesuserscontext("rma.uni objects") set.seed(20190513) skip_if_not_installed("robumeta") skip_if_not_installed("metafor") library(robumeta, quietly=TRUE) suppressMessages(library(metafor, quietly=TRUE)) data(corrdat) corr_robu <- robu(effectsize ~ males + college + binge, data = corrdat, modelweights = "CORR", studynum = studyid, var.eff.size = var) corrdat$wt <- corr_robu$data.full$r.weights corr_meta <- rma(effectsize ~ males + college + binge, data = corrdat, weights = wt, vi = var, method = "FE") test_that("CR2 t-tests agree with robumeta for correlated effects", { robu_CR2 <- vcovCR(corr_meta, cluster = corrdat$studyid, target = 1 / corrdat$wt, type = "CR2") expect_true(check_CR(corr_meta, vcov = robu_CR2)) # expect_true(check_CR(corr_meta, vcov = "CR4", cluster = corrdat$studyid)) expect_equivalent(as.matrix(robu_CR2), corr_robu$VR.r) expect_equivalent(as.matrix(vcovCR(corr_meta, cluster = corrdat$studyid, inverse_var = TRUE, type = "CR2")), corr_robu$VR.r) CR2_ttests <- coef_test(corr_meta, vcov = robu_CR2, test = "Satterthwaite") expect_equal(corr_robu$dfs, CR2_ttests$df) expect_equal(corr_robu$reg_table$prob, CR2_ttests$p_Satt) }) data(hierdat) hier_meta <- rma(effectsize ~ binge + followup + sreport + age, data = hierdat, vi = var, method = "REML") hierdat$wt <- with(hier_meta, 1 / (vi + tau2)) hier_robu <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, userweights = wt) test_that("CR2 t-tests agree with robumeta for user weighting", { robu_CR2_iv <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid) robu_CR2_not <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = hier_robu$data.full$avg.var.eff.size) expect_true(check_CR(hier_meta, vcov = robu_CR2_iv)) # expect_true(check_CR(hier_meta, vcov = "CR4", cluster = hierdat$studyid)) expect_true(check_CR(hier_meta, vcov = robu_CR2_not)) # expect_true(check_CR(hier_meta, vcov = "CR4", cluster = hierdat$studyid, # target = hier_robu$data.full$avg.var.eff.size)) expect_that(all.equal(hier_robu$VR.r, as.matrix(robu_CR2_iv)), is_a("character")) expect_equivalent(hier_robu$VR.r, as.matrix(robu_CR2_not)) # CR2_ttests <- coef_test(hier_meta, vcov = robu_CR2_not, test = "Satterthwaite") # expect_equal(hier_robu$dfs, CR2_ttests$df) # expect_equal(hier_robu$reg_table$prob, CR2_ttests$p_Satt) }) test_that("bread works", { expect_true(check_bread(corr_meta, cluster = corrdat$studyid, y = corrdat$effectsize)) X <- model_matrix(corr_meta) W <- corr_meta$weights V <- corr_meta$vi vcov_corr <- crossprod((sqrt(V) * W * X) %*% bread(corr_meta) / nobs(corr_meta)) attr(vcov_corr, "dimnames") <- attr(vcov(corr_meta), "dimnames") expect_equal(vcov(corr_meta), vcov_corr) expect_true(check_bread(hier_meta, cluster = hierdat$studyid, y = hierdat$effectsize)) expect_equal(vcov(hier_meta), bread(hier_meta) / nobs(hier_meta)) }) CR_types <- paste0("CR",0:4) test_that("order doesn't matter", { skip_on_cran() check_sort_order(hier_meta, hierdat, cluster = "studyid") }) test_that("clubSandwich works with dropped covariates", { dat_miss <- hierdat dat_miss$binge[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 10))] <- NA dat_miss$followup[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 20))] <- NA expect_warning(hier_drop <- rma(effectsize ~ binge + followup + sreport + age, data = dat_miss, vi = var, method = "REML")) subset_ind <- with(dat_miss, !is.na(binge) & !is.na(followup)) hier_complete <- rma(effectsize ~ binge + followup + sreport + age, subset = !is.na(binge) & !is.na(followup), data = dat_miss, vi = var, method = "REML") expect_error(vcovCR(hier_complete, type = "CR0", cluster = dat_miss$studyid)) CR_drop_A <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x, cluster = dat_miss$studyid)) CR_drop_B <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x, cluster = hierdat$studyid)) CR_complete <- lapply(CR_types, function(x) vcovCR(hier_complete, type = x, cluster = dat_miss$studyid[subset_ind])) expect_equal(CR_drop_A, CR_complete) expect_equal(CR_drop_B, CR_complete) test_drop_A <- lapply(CR_types, function(x) coef_test(hier_drop, vcov = x, cluster = dat_miss$studyid, test = "All", p_values = FALSE)) test_drop_B <- lapply(CR_types, function(x) coef_test(hier_drop, vcov = x, cluster = hierdat$studyid, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(hier_complete, vcov = x, cluster = dat_miss$studyid[subset_ind], test = "All", p_values = FALSE)) compare_ttests(test_drop_A, test_complete) compare_ttests(test_drop_B, test_complete) }) test_that("clubSandwich works with missing variances", { dat_miss <- hierdat dat_miss$var[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 10))] <- NA expect_warning(hier_drop <- rma(effectsize ~ binge + followup + sreport + age, data = dat_miss, vi = var, method = "REML")) subset_ind <- with(dat_miss, !is.na(var)) hier_complete <- rma(effectsize ~ binge + followup + sreport + age, subset = !is.na(var), data = dat_miss, vi = var, method = "REML") expect_error(vcovCR(hier_complete, type = "CR0", cluster = dat_miss$studyid)) CR_drop_A <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x, cluster = dat_miss$studyid)) CR_drop_B <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x, cluster = hierdat$studyid)) CR_complete <- lapply(CR_types, function(x) vcovCR(hier_complete, type = x, cluster = dat_miss$studyid[subset_ind])) expect_equal(CR_drop_A, CR_complete) expect_equal(CR_drop_B, CR_complete) }) test_that("vcovCR options work for CR2", { RE_var <- hier_meta$tau2 + hierdat$var CR2_iv <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid) expect_equal(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, inverse_var = FALSE) attr(CR2_iv, "inverse_var") <- FALSE attr(CR2_iv, "target") <- attr(CR2_not, "target") expect_equal(CR2_not, CR2_iv) expect_equal(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = RE_var), CR2_not) expect_equal(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = RE_var, inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = hierdat$var), CR2_not)) }) test_that("vcovCR works with intercept-only model and user-specified weights.", { dat <- escalc(measure="RR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat.bcg) dat$wt <- sample(1:3, size = nrow(dat), replace = TRUE) res <- rma(yi, vi, weights = wt, data=dat) meta_rob <- robust(res, cluster=dat$trial) club_rob <- coef_test(res, vcov="CR1", cluster=dat$trial, test = "naive-t") expect_equal(meta_rob$se, club_rob$SE) expect_equal(meta_rob$zval, club_rob$tstat) expect_equal(meta_rob$dfs, club_rob$df_t) expect_equal(meta_rob$pval, club_rob$p_t) expect_true(check_CR(res, vcov = "CR2", cluster = dat$trial)) test_uni <- coef_test(res, vcov="CR2", cluster=dat$trial, test = "All") res <- rma.mv(yi, vi, W = wt, random = ~ 1 | trial, data=dat) meta_rob <- robust(res, cluster=dat$trial) club_rob <- coef_test(res, vcov="CR1", test = "naive-t") expect_equal(meta_rob$se, club_rob$SE) expect_equal(meta_rob$zval, club_rob$tstat) expect_equal(meta_rob$dfs, club_rob$df_t) expect_equal(meta_rob$pval, club_rob$p_t) expect_true(check_CR(res, vcov = "CR2")) test_mv <- coef_test(res, vcov="CR2", test = "All") expect_equal(test_uni, test_mv, tolerance = 10^-5) V_club <- vcovCR(res, type = "CR2") k <- res$k yi <- res$yi wi <- diag(res$W) W <- sum(wi) wi <- wi / W vi <- diag(res$M) V <- sum(vi) ei <- residuals_CS(res) M <- sum(wi^2 * vi) ai <- 1 / sqrt(1 - 2 * wi + M / vi) V_hand <- sum(wi^2 * ai^2 * ei^2) expect_equal(V_hand, as.numeric(V_club)) pi_theta_pj <- diag(vi) - tcrossprod(rep(1,k), wi * vi) - tcrossprod(wi * vi, rep(1, k)) + M df <- M^2 / sum(tcrossprod(ai^2 * wi^2) * (pi_theta_pj^2)) expect_equal(Inf, test_uni$df_z) expect_equal(k - 1, test_uni$df_t) expect_equal(df, test_uni$df_Satt, tolerance = 10^-5) }) test_that("clubSandwich agrees with metafor::robust() for CR0.", { test_CR0 <- conf_int(corr_meta, vcov = "CR0", cluster = corrdat$studyid, test = "naive-tp", p_values = TRUE) meta_CR0 <- robust(corr_meta, cluster = corrdat$studyid, adjust = FALSE) rob_CR0 <- conf_int(meta_CR0, vcov = "CR0", cluster = corrdat$studyid, test = "naive-tp", p_values = TRUE) expect_equal(test_CR0$SE, meta_CR0$se) expect_equal(test_CR0$df, rep(meta_CR0$df, length(test_CR0$df))) expect_equal(rob_CR0, test_CR0) club_F_CR0 <- Wald_test(corr_meta, constraints = constrain_zero(2:4), vcov = "CR0", cluster = corrdat$studyid, test = "Naive-Fp") rob_F_CR0 <- Wald_test(meta_CR0, constraints = constrain_zero(2:4), vcov = "CR0", cluster = corrdat$studyid, test = "Naive-Fp") expect_equal(club_F_CR0$Fstat, meta_CR0$QM) expect_equal(club_F_CR0$df_num, meta_CR0$QMdf[1]) expect_equal(club_F_CR0$df_denom, meta_CR0$QMdf[2]) expect_equal(club_F_CR0$p_val, meta_CR0$QMp) expect_equal(club_F_CR0, rob_F_CR0) }) test_that("clubSandwich agrees with metafor::robust() for CR1p.", { test_CR1 <- conf_int(corr_meta, vcov = "CR1p", cluster = corrdat$studyid, test = "naive-tp", p_values = TRUE) meta_CR1 <- robust(corr_meta, cluster = corrdat$studyid, adjust = TRUE) rob_CR1 <- conf_int(meta_CR1, vcov = "CR1p", cluster = corrdat$studyid, test = "naive-tp", p_values = TRUE) expect_equal(test_CR1$SE, meta_CR1$se) expect_equal(test_CR1$df, rep(meta_CR1$df, length(test_CR1$df))) expect_equal(rob_CR1, test_CR1) club_F_CR1 <- Wald_test(corr_meta, constraints = constrain_zero(2:4), vcov = "CR1p", cluster = corrdat$studyid, test = "Naive-Fp") rob_F_CR1 <- Wald_test(meta_CR1, constraints = constrain_zero(2:4), vcov = "CR1p", cluster = corrdat$studyid, test = "Naive-Fp") expect_equal(club_F_CR1$Fstat, meta_CR1$QM) expect_equal(club_F_CR1$df_num, meta_CR1$QMdf[1]) expect_equal(club_F_CR1$df_denom, meta_CR1$QMdf[2]) expect_equal(club_F_CR1$p_val, meta_CR1$QMp) expect_equal(club_F_CR1, rob_F_CR1) }) test_that("clubSandwich agrees with metafor::robust() for CR2.", { skip_if(packageVersion('metafor') < "3.1.31") test_CR2 <- conf_int(corr_meta, vcov = "CR2", cluster = corrdat$studyid, p_values = TRUE) meta_CR2 <- robust(corr_meta, cluster = corrdat$studyid, clubSandwich = TRUE) rob_CR2 <- conf_int(meta_CR2, vcov = "CR2", cluster = corrdat$studyid, p_values = TRUE) expect_equal(test_CR2$SE, meta_CR2$se) expect_equal(rob_CR2, test_CR2) club_F_CR2 <- Wald_test(corr_meta, constraints = constrain_zero(2:4), vcov = "CR2", cluster = corrdat$studyid, test = "All") rob_F_CR2 <- Wald_test(meta_CR2, constraints = constrain_zero(2:4), vcov = "CR2", cluster = corrdat$studyid, test = "All") expect_equal(subset(club_F_CR2, test == "HTZ")$Fstat, meta_CR2$QM) expect_equal(subset(club_F_CR2, test == "HTZ")$df_num, meta_CR2$QMdf[1]) expect_equal(subset(club_F_CR2, test == "HTZ")$df_denom, meta_CR2$QMdf[2]) expect_equal(subset(club_F_CR2, test == "HTZ")$p_val, meta_CR2$QMp) expect_equal(club_F_CR2, rob_F_CR2) }) test_that("clubSandwich methods work on robust.rma objects.", { hier_robust <- robust(hier_meta, cluster = hierdat$studyid, adjust = TRUE) expect_equal(residuals_CS(hier_meta), residuals_CS(hier_robust)) expect_equal(coef_CS(hier_meta), coef_CS(hier_robust)) expect_equal(model_matrix(hier_meta), model_matrix(hier_robust)) expect_equal(bread(hier_meta), bread(hier_robust)) expect_equal(v_scale(hier_meta), v_scale(hier_robust)) expect_equal(targetVariance(hier_meta, cluster = hierdat$studyid), targetVariance(hier_robust, cluster = hierdat$studyid)) expect_equal(weightMatrix(hier_meta, cluster = hierdat$studyid), weightMatrix(hier_robust, cluster = hierdat$studyid)) hier_club <- robust(hier_meta, cluster = hierdat$studyid, adjust = FALSE, clubSandwich = TRUE) expect_equal(residuals_CS(hier_meta), residuals_CS(hier_club)) expect_equal(coef_CS(hier_meta), coef_CS(hier_club)) expect_equal(model_matrix(hier_meta), model_matrix(hier_club)) expect_equal(bread(hier_meta), bread(hier_club)) expect_equal(v_scale(hier_meta), v_scale(hier_club)) expect_equal(targetVariance(hier_meta, cluster = hierdat$studyid), targetVariance(hier_club, cluster = hierdat$studyid)) expect_equal(weightMatrix(hier_meta, cluster = hierdat$studyid), weightMatrix(hier_club, cluster = hierdat$studyid)) }) test_that("clubSandwich works with weights of zero.", { data("SATcoaching") n_SAT <- nrow(SATcoaching) SATcoaching$wt <- rpois(n_SAT, lambda = 0.8) table(SATcoaching$wt) rma_full <- rma.uni(yi = d, vi = V, weights = wt, mods = ~ year + test, data = SATcoaching, method = "FE") SAT_sub <- subset(SATcoaching, wt > 0) rma_sub <- rma.uni(yi = d, vi = V, weights = wt, mods = ~ year + test, data = SAT_sub, method = "FE") # Note that this only works for method = "FE" because # tau.sq estimators differ between rma_full and rma_sub CR_full <- lapply(CR_types, function(x) vcovCR(rma_full, cluster = SATcoaching$study, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(rma_sub, cluster = SAT_sub$study, type = x)) expect_equal(CR_full, CR_sub, check.attributes = FALSE) test_full <- lapply(CR_types, function(x) coef_test(rma_full, vcov = x, cluster = SATcoaching$study, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) test_sub <- lapply(CR_types, function(x) coef_test(rma_sub, vcov = x, cluster = SAT_sub$study, test = c("z","naive-t","Satterthwaite"), p_values = TRUE)) expect_equal(test_full, test_sub, check.attributes = FALSE) dat_miss <- SATcoaching miss_indicator <- sample.int(n_SAT, size = round(n_SAT / 10)) dat_miss$year[miss_indicator] <- NA with(dat_miss, table(wt, is.na(year))) expect_warning( rma_dropped <- rma.uni(yi = d, vi = V, weights = wt, mods = ~ year + test, data = dat_miss, method = "FE") ) dat_complete <- subset(dat_miss, !is.na(year)) rma_complete <- rma.uni(yi = d, vi = V, weights = wt, mods = ~ year + test, data = dat_complete, method = "FE") CR_drop <- lapply(CR_types, function(x) vcovCR(rma_dropped, cluster = dat_miss$study, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(rma_complete, cluster = dat_complete$study, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(rma_dropped, vcov = x, cluster = dat_miss$study, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(rma_complete, vcov = x, cluster = dat_complete$study, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) clubSandwich/tests/testthat/test_plm_overspecified_problem.R0000644000176200001440000000321514630154052024264 0ustar liggesuserscontext("plm objects - balanced panel with cluster-level interactions") skip_if_not_installed("plm") library(plm, quietly=TRUE) set.seed(20200721) G <- 93 N <- 4 * G Ts <- 4 beta1 <- rgamma(Ts, shape = 0.3, rate = 0.1) beta2 <- rgamma(Ts, shape = 0.2, rate = 0.1) grp <- factor(rep(1:G, each = 4 * Ts)) ID <- factor(rep(1:N, each = Ts)) trt <- factor(rep(LETTERS[1:4], times = N)) X1 <- rep(rnorm(N), each = Ts) X2 <- rep(rnorm(N), each = Ts) Y <- beta1[trt] * X1 + beta2[trt] * X2 + rnorm(N)[ID] + rnorm(N * Ts, sd = 0.5) dat <- data.frame(grp, ID, trt, X1, X2, Y) dat <- pdata.frame(dat, index = c("ID","trt")) obj <- plm(Y ~ trt + trt * X1 + trt * X2, data=dat, model="within") # cluster <- dat$grp # type <- "CR2" # target <- NULL # inverse_var <- TRUE # form <- "sandwich" # ignore_FE <- FALSE # # # colnames(model_matrix.plm(obj)) # model.matrix(obj) %>% str() # model.matrix(obj, cstcovar.rm = "all") %>% str() CR_types <- paste0("CR",0:2) test_that("vcovCR works with cluster-level interactions.", { meat_list <- lapply(CR_types, function(x) vcovCR(obj = obj, cluster=dat$grp, type = x, form = "meat")) bread_dim <- dim(bread(obj)) lapply(meat_list, function(x) expect_identical(dim(x), bread_dim)) V_CR_list <- lapply(CR_types, function(x) vcovCR(obj = obj, cluster=dat$grp, type = x)) lapply(V_CR_list, expect_s3_class, class = "vcovCR") }) test_that("CR0 agrees with built-in CRVE for plm", { V_plm <- vcovHC(obj, method = "arellano", type = "HC0") V_CR0 <- vcovCR(obj, type = "CR0") expect_equal(V_plm, as.matrix(V_CR0), check.attributes = FALSE) }) clubSandwich/tests/testthat/test_gls.R0000644000176200001440000001560014630154052017633 0ustar liggesuserscontext("gls objects") set.seed(20190513) skip_if_not_installed("nlme") library(nlme, quietly=TRUE, warn.conflicts=FALSE) data(Ovary, package = "nlme") Ovary$time_int <- 1:nrow(Ovary) lm_hom <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = Ovary) lm_power <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = Ovary, weights = varPower()) lm_AR1 <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = Ovary, correlation = corAR1(form = ~ time_int | Mare)) lm_AR1_power <- update(lm_AR1, weights = varPower()) test_that("bread works", { expect_true(check_bread(lm_hom, cluster = Ovary$Mare, y = Ovary$follicles)) expect_true(check_bread(lm_power, cluster = Ovary$Mare, y = Ovary$follicles)) expect_true(check_bread(lm_AR1, cluster = Ovary$Mare, y = Ovary$follicles)) expect_true(check_bread(lm_AR1_power, cluster = Ovary$Mare, y = Ovary$follicles)) expect_equal(vcov(lm_hom), lm_hom$sigma^2 * bread(lm_hom) / v_scale(lm_hom)) expect_equal(vcov(lm_power), lm_power$sigma^2 * bread(lm_power) / v_scale(lm_power)) expect_equal(vcov(lm_AR1), lm_AR1$sigma^2 * bread(lm_AR1) / v_scale(lm_AR1)) expect_equal(vcov(lm_AR1_power), lm_AR1_power$sigma^2 * bread(lm_AR1_power) / v_scale(lm_AR1_power)) }) test_that("vcovCR options work for CR2", { CR2_AR1 <- vcovCR(lm_AR1, type = "CR2") expect_equal(vcovCR(lm_AR1, cluster = Ovary$Mare, type = "CR2"), CR2_AR1) expect_equal(vcovCR(lm_AR1, type = "CR2", inverse_var = TRUE), CR2_AR1) expect_false(identical(vcovCR(lm_AR1, type = "CR2", inverse_var = FALSE), CR2_AR1)) target <- targetVariance(lm_AR1) expect_equal(vcovCR(lm_AR1, type = "CR2", target = target, inverse_var = TRUE), CR2_AR1) attr(CR2_AR1, "inverse_var") <- FALSE expect_equal(vcovCR(lm_AR1, type = "CR2", target = target, inverse_var = FALSE), CR2_AR1) CR2_power <- vcovCR(lm_AR1_power, type = "CR2") expect_equal(vcovCR(lm_AR1_power, cluster = Ovary$Mare, type = "CR2"), CR2_power) expect_equal(vcovCR(lm_AR1_power, type = "CR2", inverse_var = TRUE), CR2_power) expect_false(identical(vcovCR(lm_AR1_power, type = "CR2", inverse_var = FALSE), CR2_power)) target <- targetVariance(lm_AR1_power, cluster = Ovary$Mare) expect_equal(vcovCR(lm_AR1_power, type = "CR2", target = target, inverse_var = TRUE), CR2_power) attr(CR2_power, "inverse_var") <- FALSE expect_equal(vcovCR(lm_AR1_power, type = "CR2", target = target, inverse_var = FALSE), CR2_power) }) test_that("vcovCR options work for CR4", { CR4_AR1 <- vcovCR(lm_AR1, type = "CR4") expect_equal(vcovCR(lm_AR1, cluster = Ovary$Mare, type = "CR4"), CR4_AR1) expect_equal(vcovCR(lm_AR1, type = "CR4", inverse_var = TRUE), CR4_AR1) expect_false(identical(vcovCR(lm_AR1, type = "CR4", inverse_var = FALSE), CR4_AR1)) target <- targetVariance(lm_AR1) expect_equal(vcovCR(lm_AR1, type = "CR4", target = target, inverse_var = TRUE), CR4_AR1) attr(CR4_AR1, "inverse_var") <- FALSE expect_equal(vcovCR(lm_AR1, type = "CR4", target = target, inverse_var = FALSE), CR4_AR1) CR4_power <- vcovCR(lm_AR1_power, type = "CR4") expect_equal(vcovCR(lm_AR1_power, cluster = Ovary$Mare, type = "CR4"), CR4_power) expect_equal(vcovCR(lm_AR1_power, type = "CR4", inverse_var = TRUE), CR4_power) expect_false(identical(vcovCR(lm_AR1_power, type = "CR4", inverse_var = FALSE), CR4_power)) target <- targetVariance(lm_AR1_power) expect_equal(vcovCR(lm_AR1_power, type = "CR4", target = target, inverse_var = TRUE), CR4_power) attr(CR4_power, "inverse_var") <- FALSE expect_equal(vcovCR(lm_AR1_power, type = "CR4", target = target, inverse_var = FALSE), CR4_power) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(lm_AR1, vcov = "CR2")) expect_true(check_CR(lm_AR1_power, vcov = "CR2")) expect_true(check_CR(lm_AR1, vcov = "CR4")) expect_true(check_CR(lm_AR1_power, vcov = "CR4")) }) test_that("get_data works.", { re_order <- sample(nrow(Ovary)) egg_scramble <- Ovary[re_order,] gls_scramble <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = egg_scramble) scramble_dat <- get_data(gls_scramble) expect_equal(egg_scramble, scramble_dat) cars_30 <- rownames(mtcars |> subset(mpg < 30)) m1 <- gls(mpg ~ hp, data = mtcars |> subset(mpg < 30)) vcr1 <- vcovCR(m1, cluster = cars_30, type = "CR0") dat30 <- mtcars |> subset(mpg < 30) m2 <- gls(mpg ~ hp, data = dat30) vcr2 <- vcovCR(m2, cluster = cars_30, type = "CR0") m3 <- gls(mpg ~ hp, data = mtcars |> subset(mpg < 30)) m3$data <- dat30 vcr3 <- vcovCR(m3, cluster = cars_30, type = "CR0") expect_equal(vcr1, vcr2) expect_equal(vcr2, vcr3) }) CR_types <- paste0("CR",0:4) test_that("Order doesn't matter.", { check_sort_order(lm_AR1_power, dat = Ovary, tol = 10^-4, tol2 = 10^-3, tol3 = 10^-3) }) test_that("clubSandwich works with dropped observations", { dat_miss <- Ovary dat_miss$follicles[sample.int(nrow(Ovary), size = round(nrow(Ovary) / 10))] <- NA lm_dropped <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = dat_miss, correlation = corAR1(form = ~ 1 | Mare), na.action = na.omit) lm_complete <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = dat_miss, subset = !is.na(follicles), correlation = corAR1(form = ~ 1 | Mare)) CR_drop <- lapply(CR_types, function(x) vcovCR(lm_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(lm_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(lm_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(lm_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("Possible to cluster at higher level than random effects", { # create higher level pair_id <- rep(1:nlevels(Ovary$Mare), each = 3, length.out = nlevels(Ovary$Mare))[Ovary$Mare] re_order <- sample(nrow(Ovary)) dat_scramble <- Ovary[re_order,] pair_scramble <- pair_id[re_order] # cluster at higher level expect_is(vcovCR(lm_hom, type = "CR2", cluster = pair_id), "vcovCR") expect_is(vcovCR(lm_power, type = "CR2", cluster = pair_id), "vcovCR") expect_is(vcovCR(lm_AR1, type = "CR2", cluster = pair_id), "vcovCR") V <- vcovCR(lm_AR1_power, type = "CR2", cluster = pair_id) expect_is(V, "vcovCR") expect_error(vcovCR(lm_AR1, type = "CR2", cluster = pair_scramble)) expect_error(vcovCR(lm_AR1_power, type = "CR2", cluster = pair_scramble)) # check that result does not depend on sort-order V_scramble <- vcovCR(update(lm_AR1_power, data = dat_scramble), type = "CR2", cluster = pair_scramble) expect_equal(diag(V), diag(V_scramble), tol = 10^-6) }) clubSandwich/tests/testthat/test_lme_MVML.R0000644000176200001440000001007614630154052020460 0ustar liggesuserscontext("multi-variate multi-level lme objects") set.seed(20190513) skip_on_cran() dat <- read.table(file="https://raw.githubusercontent.com/wviechtb/multivariate_multilevel_models/master/data.dat", header=TRUE, sep="\t") dat$pa <- rowMeans(dat[, grepl("pa", names(dat))]) dat$na <- rowMeans(dat[, grepl("na", names(dat))]) # keep only variables that are needed dat <- dat[, c("id", "sex", "beep", "pa", "na")] # keep only the first 10 IDs dat <- subset(dat, id <= 10) # change into very long format dat <- reshape(dat, direction="long", varying=c("pa","na"), v.names="y", idvar="obs", timevar="outcome") dat$obs <- NULL dat <- dat[order(dat$id, dat$beep, dat$outcome),] rownames(dat) <- 1:nrow(dat) dat$outnum <- dat$outcome dat$outcome <- factor(dat$outcome) library(nlme, quietly=TRUE, warn.conflicts=FALSE) MVML_full <- lme(y ~ outcome - 1, random = ~ outcome - 1 | id, weights = varIdent(form = ~ 1 | outcome), correlation = corSymm(form = ~ outnum | id/beep), data = dat, na.action = na.omit) MVML_diag <- lme(y ~ outcome - 1, random = ~ outcome - 1 | id, weights = varIdent(form = ~ 1 | outcome), data = dat, na.action = na.omit) gls_full <- gls(y ~ outcome - 1, weights = varIdent(form = ~ 1 | outcome), correlation = corSymm(form = ~ outnum | id/beep), data = dat, na.action = na.omit) objects <- list(MVML_full = MVML_full, MVML_diag = MVML_diag, gls = gls_full) CR2_mats <- lapply(objects, vcovCR, type = "CR2") test_that("bread works", { bread_checks <- lapply(objects, check_bread, cluster = dat$id, y = dat$y) expect_true(all(unlist(bread_checks))) obj_vcovs <- lapply(objects, vcov) obj_bread <- lapply(objects, function(obj) obj$sigma^2 * sandwich::bread(obj) / v_scale(obj)) expect_equal(obj_vcovs, obj_bread) }) test_that("vcovCR options work for CR2", { expect_identical(vcovCR(MVML_full, cluster = dat$id, type = "CR2"), CR2_mats[["MVML_full"]]) expect_equal(vcovCR(MVML_full, type = "CR2", inverse_var = TRUE), CR2_mats[["MVML_full"]]) expect_false(identical(vcovCR(MVML_full, type = "CR2", inverse_var = FALSE), CR2_mats[["MVML_full"]])) target <- targetVariance(MVML_full) expect_equal(vcovCR(MVML_full, type = "CR2", target = target, inverse_var = TRUE), CR2_mats[["MVML_full"]]) attr(CR2_mats[["MVML_full"]], "inverse_var") <- FALSE expect_equal(vcovCR(MVML_full, type = "CR2", target = target, inverse_var = FALSE), CR2_mats[["MVML_full"]]) }) test_that("CR2 is target-unbiased", { CR2_checks <- mapply(check_CR, obj = objects, vcov = CR2_mats) expect_true(all(CR2_checks)) }) CR_types <- paste0("CR",0:3) test_that("Order doesn't matter.", { check_sort_order(MVML_full, dat, seed = 20200530) check_sort_order(MVML_diag, dat, seed = 20200530) }) test_that("clubSandwich works with dropped observations", { dat_miss <- dat dat_miss$y[sample.int(nrow(dat), size = round(nrow(dat) / 10))] <- NA obj_dropped <- update(MVML_full, data = dat_miss, na.action = na.omit) obj_complete <- update(MVML_full, data = dat_miss, subset = !is.na(y)) CR_drop <- lapply(CR_types, function(x) vcovCR(obj_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(obj_complete, type = x)) expect_identical(CR_drop, CR_complete) test_drop <- lapply(CR_drop, function(x) coef_test(obj_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_complete, function(x) coef_test(obj_complete, vcov = x, test = "All", p_values = FALSE)) expect_identical(test_drop, test_complete) }) test_that("Possible to cluster at higher level than random effects", { # create 4th level n_groups <- nlevels(factor(dat$id)) group_id <- rep(1:n_groups, each = 4)[dat$id] # cluster at level 4 expect_is(vcovCR(MVML_full, type = "CR2", cluster = group_id), "vcovCR") expect_is(vcovCR(MVML_diag, type = "CR2", cluster = group_id), "vcovCR") }) clubSandwich/tests/testthat/test_geeglm.R0000644000176200001440000003034714634637360020327 0ustar liggesuserscontext("geeglm objects") set.seed(202201030) skip_if_not_installed("geepack") library(geepack) J <- 20 tp <- 5 # Simulating a dataset idvar <- rep(1:J, each=tp) idvar2 <- factor(sample(LETTERS)[idvar]) timeorder <- rep(1:tp, J) tvar <- timeorder + rnorm(length(timeorder)) x1 <- rnorm(length(timeorder)) x2 <- rnorm(J)[idvar] uuu <- rep(rnorm(J), each=tp) yvar <- 1 + 0.4 * x1 + 0.2 * x2 + 2 * tvar + uuu + rnorm(length(tvar)) simdat <- data.frame(idvar, timeorder, x1, x2, tvar, yvar, idvar2) simdatPerm <- simdat[sample(nrow(simdat)),] simdatPerm <- simdatPerm[order(simdatPerm$idvar),] wav <- simdatPerm$timeorder # AR1 + wave geeglm_AR1_wav <- geeglm(yvar ~ tvar + x1, id = idvar, data = simdatPerm, corstr = "ar1", waves = timeorder) geeglm_AR1_wav # AR1 geeglm_AR1 <- geeglm(yvar ~ tvar, id = idvar, data = simdat, family = "gaussian", corstr = "ar1") # Independence geeglm_ind <- geeglm(yvar ~ tvar + x1 + x2, id = idvar, data = simdat, corstr = "independence") # Exchangeable geeglm_exch <- geeglm(yvar ~ tvar + x2, id = idvar, data = simdat, corstr = "exchangeable") geeglm_exch2 <- geeglm(yvar ~ tvar + x2, id = idvar2, data = simdat, corstr = "exchangeable") # Unstructured geeglm_unstr <- geeglm(yvar ~ tvar, id = idvar, data = simdat, corstr = "unstructured") geeglm_unstr2 <- geeglm(yvar ~ tvar, id = idvar2, data = simdat, corstr = "unstructured") # User-defined zcor <- genZcor(clusz = table(simdat$idvar), waves = simdat$timeorder, corstrv = 4) zcor_user <- zcor geeglm_user <- geeglm(yvar ~ tvar + x1, id = idvar, waves = timeorder, data = simdat, zcor = zcor_user, corstr = "userdefined") # User-defined, Toeplitz zcor_toep <- matrix(NA, nrow(zcor), 4) zcor_toep[,1] <- apply(zcor[,c(1, 5, 8,10)], 1, sum) zcor_toep[,2] <- apply(zcor[,c(2, 6, 9)], 1, sum) zcor_toep[,3] <- apply(zcor[,c(3, 7)], 1, sum) zcor_toep[,4] <- zcor[,4] geeglm_toep <- geeglm(yvar ~ tvar + x1, id = idvar, waves = timeorder, data = simdat, zcor = zcor_toep, corstr = "userdefined") # Fixed correlation cor_fix <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125, 0.5 , 1 , 0.25, 0.125, 0.125, 0.25 , 0.25 , 1 , 0.5 , 0.125, 0.125, 0.125, 0.5 , 1 , 0.125, 0.125, 0.125, 0.125, 0.125, 1 ), nrow=5, ncol=5) zcor_fix <- fixed2Zcor(cor_fix, id=simdat$idvar, waves=simdat$timeorder) geeglm_fix <- geeglm(yvar ~ tvar + x1 + x2, id = idvar, waves = timeorder, data = simdat, zcor = zcor_fix, corstr = "fixed") test_that("bread works", { expect_true(check_bread(geeglm_AR1_wav, cluster = simdatPerm$idvar, y = simdatPerm$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_AR1, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_ind, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_exch, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_exch2, cluster = simdat$idvar2, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_unstr, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_unstr2, cluster = simdat$idvar2, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_user, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_toep, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) expect_true(check_bread(geeglm_fix, cluster = simdat$idvar, y = simdat$yvar, tol = 1e-5)) }) test_that("vcovCR options work for CR2", { CR2_AR1_wav <- vcovCR(geeglm_AR1_wav, type = "CR2") expect_equal(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR2"), CR2_AR1_wav) expect_equal(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR2", inverse_var = TRUE), CR2_AR1_wav) expect_false(identical(vcovCR(geeglm_AR1_wav, type = "CR2", cluster = simdatPerm$idvar, inverse_var = FALSE), CR2_AR1_wav)) target <- targetVariance(geeglm_AR1_wav, cluster = simdatPerm$idvar) expect_equal(vcovCR(geeglm_AR1_wav, type = "CR2", target = target, inverse_var = TRUE), CR2_AR1_wav, ignore_attr = TRUE) attr(CR2_AR1_wav, "inverse_var") <- FALSE expect_equal(vcovCR(geeglm_AR1_wav, type = "CR2", target = target, inverse_var = FALSE), CR2_AR1_wav, ignore_attr = TRUE) }) test_that("vcovCR options work for CR4", { CR4_AR1_wav <- vcovCR(geeglm_AR1_wav, type = "CR4") expect_equal(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR4"), CR4_AR1_wav) expect_equal(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR4", inverse_var = TRUE), CR4_AR1_wav) expect_false(identical(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR4", inverse_var = FALSE), CR4_AR1_wav)) target <- targetVariance(geeglm_AR1_wav, cluster = simdatPerm$idvar) expect_equal(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR4", target = target, inverse_var = TRUE), CR4_AR1_wav, ignore_attr = TRUE) attr(CR4_AR1_wav, "inverse_var") <- FALSE expect_equal(vcovCR(geeglm_AR1_wav, cluster = simdatPerm$idvar, type = "CR4", target = target, inverse_var = FALSE), CR4_AR1_wav, ignore_attr = TRUE) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(geeglm_AR1_wav, cluster = simdatPerm$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_AR1, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_ind, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_exch, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_exch2, cluster = simdat$idvar2, vcov = "CR2")) expect_true(check_CR(geeglm_unstr, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_unstr2, cluster = simdat$idvar2, vcov = "CR2")) expect_true(check_CR(geeglm_user, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_toep, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_fix, cluster = simdat$idvar, vcov = "CR2")) expect_true(check_CR(geeglm_AR1_wav, cluster = simdatPerm$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_AR1, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_ind, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_exch, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_exch2, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_unstr, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_unstr2, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_user, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_toep, cluster = simdat$idvar, vcov = "CR4")) expect_true(check_CR(geeglm_fix, cluster = simdat$idvar, vcov = "CR4")) }) CR_types <- paste0("CR",0:4) test_that("Order doesn't matter.", { skip_on_cran() check_sort_order(geeglm_ind, dat = simdat, CR_types = CR_types) check_sort_order(geeglm_ind, dat = simdat, arrange = "idvar2", CR_types = CR_types) check_sort_order(geeglm_exch, dat = simdat, arrange = "idvar", CR_types = CR_types) check_sort_order(geeglm_exch2, dat = simdat, arrange = "idvar", CR_types = CR_types) check_sort_order(geeglm_exch2, dat = simdat, arrange = "idvar2", CR_types = CR_types) expect_error(check_sort_order(geeglm_unstr, dat = simdat, arrange = "idvar", CR_types = CR_types)) }) test_that("clubSandwich works with dropped observations", { dat_miss <- simdat dat_miss$yvar[sample.int(nrow(simdat), size = round(nrow(simdat) / 10))] <- NA dat_complete <- subset(dat_miss, !is.na(yvar)) mod_dropped <- geeglm(yvar ~ tvar, id = idvar, data = dat_miss, corstr = "independence") mod_complete <- geeglm(yvar ~ tvar, id = idvar, data = dat_complete, corstr = "independence") CR_drop <- lapply(CR_types, function(x) vcovCR(mod_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(mod_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(mod_dropped, cluster = dat_miss$idvar, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(mod_complete, cluster = dat_complete$idvar, vcov = x, test = "All", p_values = FALSE)) compare_ttests(test_drop, test_complete) }) test_that("vcovCR works for clustering variables higher than id variable.", { # create higher level pair_id <- rep(1:nlevels(as.factor(simdat$idvar)), each = 3, length.out = nlevels(as.factor(simdat$idvar)))[as.factor(simdat$idvar)] # factor cluster pair_id <- factor(pair_id) # cluster at higher level V_AR1 <- vcovCR(geeglm_AR1, type = "CR2", cluster = pair_id) V_AR1_wav <- vcovCR(geeglm_AR1_wav, type = "CR2", cluster = pair_id) V_ind <- vcovCR(geeglm_ind, type = "CR2", cluster = pair_id) V_exch <- vcovCR(geeglm_exch, type = "CR2", cluster = pair_id) V_exch2 <- vcovCR(geeglm_exch2, type = "CR2", cluster = pair_id) V_unstr <- vcovCR(geeglm_unstr, type = "CR2", cluster = pair_id) V_unstr2 <- vcovCR(geeglm_unstr2, type = "CR2", cluster = pair_id) V_user <- vcovCR(geeglm_user, type = "CR2", cluster = pair_id) V_toep <- vcovCR(geeglm_toep, type = "CR2", cluster = pair_id) V_fix <- vcovCR(geeglm_fix, type = "CR2", cluster = pair_id) expect_is(V_AR1, "vcovCR") expect_is(V_AR1_wav, "vcovCR") expect_is(V_ind, "vcovCR") expect_is(V_exch, "vcovCR") expect_is(V_exch2, "vcovCR") expect_is(V_unstr, "vcovCR") expect_is(V_unstr2, "vcovCR") expect_is(V_user, "vcovCR") expect_is(V_toep, "vcovCR") expect_is(V_fix, "vcovCR") # check that result does not depend on sort-order scramble_id <- factor(simdat$idvar, levels = sample(1:J)) dat_higher <- cbind(simdat, pair_id = factor(pair_id), scramble_id) dat_higher <- dat_higher[order(dat_higher$scramble_id),] dat_scramble <- dat_higher[sample(nrow(dat_higher)),] dat_scramble <- dat_scramble[order(dat_scramble$scramble_id),] V_AR1_scramble <- vcovCR(update(geeglm_AR1, data = dat_higher), type = "CR2", cluster = dat_higher$pair_id) expect_equal(V_AR1, V_AR1_scramble, tol = 10^-6, check.attributes = FALSE) V_AR1_wav_scramble <- vcovCR(update(geeglm_AR1_wav, data = dat_higher), type = "CR2", cluster = dat_higher$pair_id) expect_equal(V_AR1_wav, V_AR1_wav_scramble, tol = 10^-6, check.attributes = FALSE) V_ind_scramble <- vcovCR(update(geeglm_ind, data = dat_scramble), type = "CR2", cluster = dat_scramble$pair_id) expect_equal(V_ind, V_ind_scramble, tol = 10^-6, check.attributes = FALSE) V_exch2_scramble <- vcovCR(update(geeglm_exch2, data = dat_scramble), type = "CR2", cluster = dat_scramble$pair_id) expect_equal(V_exch2, V_exch2_scramble, tol = 10^-6, check.attributes = FALSE) V_unstr_scramble <- vcovCR(update(geeglm_unstr, data = dat_higher), type = "CR2", cluster = dat_higher$pair_id) expect_equal(V_unstr, V_unstr_scramble, tol = 10^-6, check.attributes = FALSE) }) check_geeglm <- function(obj) { cr0_pack <- vcov(obj) cr0_club <- as.matrix(vcovCR(obj, type = "CR0")) expect_equal(cr0_pack, cr0_club) cr3_pack <- vcov(update(obj, std.err = "jack")) cr3_club <- as.matrix(vcovCR(obj, type = "CR3")) J <- length(unique(obj$id)) p <- nrow(obj$geese$infls) f <- (J - p) / J expect_equal(cr3_pack, f * cr3_club) } test_that("vcovCR agrees with geeglm for CR0 and CR3.", { check_geeglm(geeglm_AR1_wav) check_geeglm(geeglm_AR1) check_geeglm(geeglm_ind) check_geeglm(geeglm_exch) check_geeglm(geeglm_exch2) check_geeglm(geeglm_unstr) check_geeglm(geeglm_unstr2) check_geeglm(geeglm_user) check_geeglm(geeglm_toep) check_geeglm(geeglm_fix) }) clubSandwich/tests/testthat/test_Wald.R0000644000176200001440000003607614630154052017747 0ustar liggesuserscontext("Wald tests") set.seed(20190513) skip_if_not_installed("carData") data(Duncan, package = "carData") Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) Duncan_int <- lm(prestige ~ type * (income + education), data=Duncan) coefs_int <- coef(Duncan_int) coef_names_int <- names(coefs_int) Duncan_int_CR2 <- vcovCR(Duncan_int, type = "CR2", cluster = Duncan$cluster) Duncan_sep <- lm(prestige ~ 0 + type + type:(income + education), data=Duncan) coefs_sep <- coef(Duncan_sep) coef_names_sep <- names(coefs_sep) Duncan_sep_CR2 <- vcovCR(Duncan_sep, type = "CR2", cluster = Duncan$cluster) test_that("constrain_equal expressions are equivalent", { constraints_lgl <- grepl(":education", coef_names_sep) constraints_int <- which(constraints_lgl) constraints_num <- as.numeric(constraints_int) constraints_char <- coef_names_sep[constraints_lgl] constraints_mat <- cbind(matrix(0L, 2, 6), matrix(c(-1L, -1L, 1L, 0L, 0L, 1L), 2, 3)) expect_identical(constrain_equal(":education", coefs_sep, reg_ex = TRUE), constraints_mat) expect_identical(constrain_equal(constraints_lgl, coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_int, coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_num, coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_char, coefs_sep), constraints_mat) expect_type(constrain_equal(":education", reg_ex = TRUE), "closure") expect_identical(constrain_equal(":education", reg_ex = TRUE)(coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_lgl)(coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_int)(coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_num)(coefs_sep), constraints_mat) expect_identical(constrain_equal(constraints_char)(coefs_sep), constraints_mat) constraint_list <- constrain_equal(list(type = 1:3, income = 4:6, edu = 7:9), coefs = coefs_sep) constraint_func <- constrain_equal(list(type = 1:3, income = 4:6, edu = 7:9)) expect_identical(constraint_list, constraint_func(coefs_sep)) Wald_A <- Wald_test(Duncan_sep, constraints = constraint_list, vcov = Duncan_sep_CR2, type = "All") Wald_B <- Wald_test(Duncan_sep, constraints = constraint_func, vcov = Duncan_sep_CR2, type = "All") expect_identical(Wald_A, Wald_B) }) test_that("constrain_pairwise expressions are equivalent", { constraints_lgl <- grepl(":education", coef_names_sep) constraints_int <- which(constraints_lgl) constraints_num <- as.numeric(constraints_int) constraints_char <- coef_names_sep[constraints_lgl] constraints_mat <- constrain_pairwise(":education", coefs_sep, reg_ex = TRUE) expect_identical(length(constraints_mat), sum(constraints_lgl)) expect_identical(constrain_pairwise(constraints_lgl, coefs_sep), constraints_mat) expect_identical(constrain_pairwise(constraints_int, coefs_sep), constraints_mat) expect_identical(constrain_pairwise(constraints_num, coefs_sep), constraints_mat) expect_identical(constrain_pairwise(constraints_char, coefs_sep), constraints_mat) expect_type(constrain_pairwise(":education", reg_ex = TRUE), "closure") expect_identical(constrain_pairwise(constraints_lgl)(coefs_sep), constraints_mat) expect_identical(constrain_pairwise(constraints_int)(coefs_sep), constraints_mat) expect_identical(constrain_pairwise(constraints_num)(coefs_sep), constraints_mat) expect_identical(constrain_pairwise(constraints_char)(coefs_sep), constraints_mat) constraint_list <- constrain_pairwise(list(type = 1:3, income = 4:6, edu = 7:9), coefs = coefs_sep) constraint_func <- constrain_pairwise(list(type = 1:3, income = 4:6, edu = 7:9)) expect_identical(constraint_list, constraint_func(coefs_sep)) Wald_A <- Wald_test(Duncan_sep, constraints = constraint_list, vcov = Duncan_sep_CR2, type = "All") Wald_B <- Wald_test(Duncan_sep, constraints = constraint_func, vcov = Duncan_sep_CR2, type = "All") expect_identical(Wald_A, Wald_B) }) test_that("constrain_zero expressions are equivalent", { constraints_lgl <- grepl("typeprof:", coef_names_int) constraints_int <- which(constraints_lgl) constraints_num <- as.numeric(constraints_int) constraints_char <- coef_names_int[constraints_lgl] constraints_mat <- diag(1L, nrow = length(coef_names_int))[constraints_lgl,,drop=FALSE] expect_equal(constrain_zero("typeprof:", coefs_int, reg_ex = TRUE), constraints_mat) expect_equal(constrain_zero(constraints_lgl, coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_int, coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_num, coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_char, coefs_int), constraints_mat) expect_type(constrain_zero("typeprof:", reg_ex = TRUE), "closure") expect_equal(constrain_zero("typeprof:", reg_ex = TRUE)(coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_lgl)(coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_int)(coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_num)(coefs_int), constraints_mat) expect_equal(constrain_zero(constraints_char)(coefs_int), constraints_mat) constraint_list <- constrain_zero(list(type = 2:3, income = 6:7, edu = 8:9), coefs = coefs_int) constraint_func <- constrain_zero(list(type = 2:3, income = 6:7, edu = 8:9)) expect_equal(constraint_list, constraint_func(coefs_int)) Wald_A <- Wald_test(Duncan_int, constraints = constraint_list, vcov = Duncan_int_CR2, type = "All") Wald_B <- Wald_test(Duncan_int, constraints = constraint_func, vcov = Duncan_int_CR2, type = "All") expect_equal(Wald_A, Wald_B) }) test_that("constraint expressions are equivalent across specifications", { skip_on_cran() skip_if(R.version$major < "4", "Skip for R versions below 4.") constraints_eq <- constrain_equal( list(type = 1:3, income = 4:6, edu = 7:9), coefs = coefs_sep ) # constraints_eq$all <- do.call(rbind, constraints_eq) constraints_null <- constrain_zero( list(type = 2:3, income = 6:7, edu = 8:9), coefs = coefs_int ) # constraints_null$all <- do.call(rbind, constraints_null) Wald_eq <- Wald_test(Duncan_sep, constraints_eq, vcov = Duncan_sep_CR2, test = c("Naive-F","HTZ","EDF"), tidy = TRUE) Wald_zero <- Wald_test(Duncan_int, constraints_null, vcov = Duncan_int_CR2, test = c("Naive-F","HTZ","EDF"), tidy = TRUE) compare_Waldtests(Wald_eq, Wald_zero) pairwise_sep <- constrain_pairwise( list(type = 1:3, income = 4:6, edu = 7:9), coefs = coefs_sep ) pairwise_int <- constrain_pairwise( list(type = 2:3, income = 6:7, edu = 8:9), coefs = coefs_int, with_zero = TRUE ) pairwise_sep <- Wald_test(Duncan_sep, pairwise_sep, vcov = Duncan_sep_CR2, tidy = TRUE) pairwise_int <- Wald_test(Duncan_int, pairwise_int, vcov = Duncan_int_CR2, tidy = TRUE) compare_Waldtests(pairwise_sep, pairwise_int) }) test_that("Wald test is equivalent to Satterthwaite for q = 1.", { skip_on_cran() t_tests_sep <- coef_test(Duncan_sep, vcov = Duncan_sep_CR2) constraints_sep <- as.list(1:9) names(constraints_sep) <- coef_names_sep F_tests_sep <- Wald_test(Duncan_sep, vcov = Duncan_sep_CR2, constraints = constrain_zero(constraints_sep), tidy = TRUE) expect_equal(t_tests_sep$tstat^2, F_tests_sep$Fstat, tol = 10^-5) expect_equal(rep(1, 9), F_tests_sep$df_num, tol = 10^-5) expect_equal(t_tests_sep$df, F_tests_sep$df_denom, tol = 10^-5) expect_equal(t_tests_sep$p_Satt, F_tests_sep$p_val, tol = 10^-5) t_tests_int <- coef_test(Duncan_int, vcov = Duncan_int_CR2) constraints_int <- as.list(1:9) names(constraints_int) <- coef_names_int F_tests_int <- Wald_test(Duncan_int, vcov = Duncan_int_CR2, constraints = constrain_zero(constraints_int), tidy = TRUE) expect_equal(t_tests_int$tstat^2, F_tests_int$Fstat, tol = 10^-5) expect_equal(rep(1, 9), F_tests_int$df_num, tol = 10^-5) expect_equal(t_tests_int$df, F_tests_int$df_denom, tol = 10^-5) expect_equal(t_tests_int$p_Satt, F_tests_int$p_val, tol = 10^-5) }) skip_if_not_installed("AER") data(STAR, package = "AER") # clean up a few variables levels(STAR$stark)[3] <- "aide" levels(STAR$schoolk)[1] <- "urban" STAR <- subset(STAR, !is.na(schoolidk), select = c(schoolidk, schoolk, stark, gender, ethnicity, math1, lunchk)) lm_urbanicity <- lm(math1 ~ schoolk * stark + gender + ethnicity + lunchk, data = STAR) V_urbanicity <- vcovCR(lm_urbanicity, cluster = STAR$schoolidk, type = "CR2") test_that("Wald_test works with lists.", { test_A <- Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity) test_B <- Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE), vcov = V_urbanicity) C_list <- list( `Any interaction` = constrain_zero("schoolk.+:stark", coef(lm_urbanicity), reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", coef(lm_urbanicity), reg_ex = TRUE) ) D_list <- constrain_zero(constraints = list( `Any interaction` = "schoolk.+:stark", `Small vs regular` = "schoolk.+:starksmall" ), reg_ex = TRUE) test_C <- Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity) test_D <- Wald_test(lm_urbanicity, constraints = D_list, vcov = V_urbanicity) test_E <- Wald_test( lm_urbanicity, constraints = list( `Any interaction` = constrain_zero("schoolk.+:stark", reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE) ), vcov = V_urbanicity ) expect_identical(test_A, test_C$`Any interaction`) expect_identical(test_A, test_D$`Any interaction`) expect_identical(test_A, test_E$`Any interaction`) expect_identical(test_B, test_C$`Small vs regular`) expect_identical(test_B, test_D$`Small vs regular`) expect_identical(test_B, test_E$`Small vs regular`) }) test_that("Wald_test has informative error messages.", { expect_error( Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity, test = "none" ) ) A <- Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity, test = c("none","HTA") ) B <- Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity, test = "All" ) expect_equal(A, subset(B, test == "HTA"), check.attributes = FALSE) }) test_that("Wald_test works for intercept-only models.", { lm_int <- lm(math1 ~ 1, data = STAR) vcov_int <- vcovCR(lm_int, cluster = STAR$schoolidk, type = "CR2") F_test <- Wald_test(lm_int, constraints = constrain_zero(1), vcov = vcov_int, test = c("HTZ","HTA","HTB")) t_test <- coef_test(lm_int, vcov = vcov_int) expect_equal(F_test$Fstat, rep(t_test$tstat^2, 3L)) expect_equal(F_test$df_denom, rep(t_test$df, 3L)) expect_equal(F_test$p_val, rep(t_test$p_Satt, 3L)) lm_sep <- lm(math1 ~ 0 + schoolk, data = STAR) vcov_sep <- vcovCR(lm_sep, cluster = STAR$schoolidk, type = "CR2") F_test <- Wald_test(lm_sep, constraints = constrain_pairwise(1:3, with_zero = TRUE), vcov = vcov_sep, test = "HTZ", tidy = TRUE) t_test <- coef_test(lm_sep, vcov = vcov_sep) expect_equal(F_test$Fstat[1:3], t_test$tstat^2) expect_equal(F_test$df_denom[1:3], t_test$df) expect_equal(F_test$p_val[1:3], t_test$p_Satt) }) test_that("Wald_test fails gracefully when between-cluster variance of coefficients isn't identified.", { skip_if_not_installed("metafor") suppressPackageStartupMessages(library(metafor)) dat <- dat.bcg dat <- escalc(measure="RR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat, subset=-5) res <- rma(yi, vi, data=dat, mods = ~ 0 + alloc) Vmat <- vcovCR(res, cluster=dat$trial, type="CR2") expect_equal(Vmat[1,1], 0) t_tests <- coef_test(res, cluster=dat$trial, vcov="CR2") expect_true(is.na(t_tests$df_Satt[1])) expect_true(is.na(t_tests$p_Satt[1])) CI <- conf_int(res, cluster=dat$trial, vcov="CR2") expect_true(is.na(CI$CI_L[1])) expect_true(is.na(CI$CI_U[1])) Wald1 <- Wald_test( res, cluster=dat$trial, vcov="CR2", constraints=constrain_equal(1:3), test = "All" ) expect_s3_class(Wald1, "Wald_test_clubSandwich") expect_error( Wald_test( res, cluster=dat$trial, vcov="CR2", constraints=constrain_zero(1:3) ), regexp = "not positive definite" ) Wald2 <- Wald_test( res, cluster=dat$trial, vcov="CR2", constraints = list(A = constrain_equal(1:3), B = constrain_zero(1:3)), test = "All" ) expect_s3_class(Wald2$A, "Wald_test_clubSandwich") expect_s3_class(Wald2$B, "Wald_test_clubSandwich") expect_identical(Wald1, Wald2$A) expect_true(all(is.na(Wald2$B$Fstat))) expect_true(all(is.na(Wald2$B$p_val))) Wald3 <- Wald_test( res, cluster=dat$trial, vcov="CR2", constraints = list(A = constrain_equal(1:3), B = constrain_zero(1:3)), tidy = TRUE ) expect_s3_class(Wald3, "Wald_test_clubSandwich") expect_equivalent(Wald1[Wald1$test=="HTZ",], Wald3[1,-1]) expect_true(is.na(Wald3[2,"Fstat"])) expect_true(is.na(Wald3[2,"p_val"])) Wald4 <- Wald_test( res, cluster=dat$trial, vcov="CR2", constraints=constrain_pairwise(1:3, with_zero = TRUE), tidy = TRUE ) expect_s3_class(Wald4, "Wald_test_clubSandwich") expect_true(is.na(Wald4[1,"Fstat"])) expect_true(is.na(Wald4[1,"p_val"])) }) clubSandwich/tests/testthat/test_rma-mv.R0000644000176200001440000006152014630154052020247 0ustar liggesuserscontext("rma.mv objects") set.seed(20190513) skip_if_not_installed("robumeta") skip_if_not_installed("metafor") CR_types <- paste0("CR",0:4) library(robumeta, quietly=TRUE) suppressMessages(library(metafor, quietly=TRUE)) data(corrdat) corr_robu <- robu(effectsize ~ males + college + binge, data = corrdat, modelweights = "CORR", studynum = studyid, var.eff.size = var) corrdat$wt <- corr_robu$data.full$r.weights corr_meta <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = var, W = wt, method = "FE") test_that("CR2 t-tests agree with robumeta for correlated effects", { robu_CR2 <- vcovCR(corr_meta, cluster = corrdat$studyid, target = 1 / corrdat$wt, type = "CR2") expect_true(check_CR(corr_meta, vcov = robu_CR2)) # expect_true(check_CR(corr_meta, vcov = "CR4", cluster = corrdat$studyid)) expect_equivalent(as.matrix(robu_CR2), corr_robu$VR.r) expect_that(all.equal(as.matrix(vcovCR(corr_meta, cluster = corrdat$studyid, inverse_var = TRUE, type = "CR2")), corr_robu$VR.r), is_a("character")) CR2_ttests <- coef_test(corr_meta, vcov = robu_CR2, test = "Satterthwaite") expect_equal(corr_robu$dfs, CR2_ttests$df) expect_equal(corr_robu$reg_table$prob, CR2_ttests$p_Satt) }) data(hierdat) hier_meta <- rma.mv(effectsize ~ binge + followup + sreport + age, data = hierdat, random = list(~ 1 | esid, ~ 1 | studyid), V = var, method = "REML") hier_robu <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, modelweights = "HIER") test_that("CR2 t-tests do not exactly agree with robumeta for hierarchical weighting", { robu_CR2_iv <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid) robu_CR2_not <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = hier_robu$data.full$avg.var.eff.size) expect_true(check_CR(hier_meta, vcov = robu_CR2_iv)) # expect_true(check_CR(hier_meta, vcov = "CR4")) expect_true(check_CR(hier_meta, vcov = robu_CR2_not)) # expect_true(check_CR(hier_meta, vcov = "CR4", # target = hier_robu$data.full$avg.var.eff.size)) expect_that(all.equal(hier_robu$VR.r, as.matrix(robu_CR2_iv), check.attributes=FALSE), is_a("character")) expect_that(all.equal(hier_robu$VR.r, as.matrix(robu_CR2_not), check.attributes=FALSE), is_a("character")) CR2_ttests <- coef_test(hier_meta, vcov = robu_CR2_not, test = "Satterthwaite") expect_that(all.equal(hier_robu$dfs, CR2_ttests$df), is_a("character")) expect_that(all.equal(hier_robu$reg_table$prob, CR2_ttests$p_Satt), is_a("character")) }) dat_long <- to.long(measure="OR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat.bcg) levels(dat_long$group) <- c("exp", "con") dat_long$group <- relevel(dat_long$group, ref="con") dat_long$esid <- factor(1:nrow(dat_long)) dat_long <- escalc(measure="PLO", xi=out1, mi=out2, data=dat_long) rma_G <- rma.mv(yi, vi, mods = ~ group, random = ~ group | study, struct="CS", data=dat_long) rma_S <- rma.mv(yi, vi, mods = ~ group, random = list(~ 1 | esid, ~ 1 | study), data=dat_long) test_that("withS and withG model specifications agree.", { CR_G <- lapply(CR_types, function(x) vcovCR(rma_G, type = x)) CR_S <- lapply(CR_types, function(x) vcovCR(rma_S, type = x)) expect_equivalent(CR_G, CR_S) tests_G <- lapply(CR_types, function(x) coef_test(rma_G, vcov = x, test = "All", p_values = FALSE)) tests_S <- lapply(CR_types, function(x) coef_test(rma_S, vcov = x, test = "All", p_values = FALSE)) expect_equal(tests_G, tests_S, tolerance = 1e-6) }) test_that("bread works", { expect_true(check_bread(corr_meta, cluster = corrdat$studyid, y = corrdat$effectsize)) X <- model_matrix(corr_meta) W <- corr_meta$W V <- corr_meta$vi vcov_corr <- bread(corr_meta) %*% t(X) %*% W %*% (V * W) %*% X %*% bread(corr_meta) / nobs(corr_meta)^2 attr(vcov_corr, "dimnames") <- attr(vcov(corr_meta), "dimnames") expect_equal(vcov(corr_meta), vcov_corr) expect_true(check_bread(hier_meta, cluster = hierdat$studyid, y = hierdat$effectsize)) expect_equal(vcov(hier_meta), bread(hier_meta) / nobs(hier_meta)) expect_true(check_bread(rma_G, cluster = dat_long$study, y = dat_long$yi)) expect_equal(vcov(rma_G), bread(rma_G) / nobs(rma_G)) expect_true(check_bread(rma_S, cluster = dat_long$study, y = dat_long$yi)) expect_equal(vcov(rma_S), bread(rma_S) / nobs(rma_S)) }) test_that("order doesn't matter", { skip_on_cran() check_sort_order(hier_meta, hierdat) }) test_that("clubSandwich works with dropped covariates", { dat_miss <- hierdat dat_miss$binge[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 10))] <- NA dat_miss$followup[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 20))] <- NA expect_warning(hier_drop <- rma.mv(effectsize ~ binge + followup + sreport + age, random = list(~ 1 | esid, ~ 1 | studyid), data = dat_miss, V = var, method = "REML")) hier_complete <- rma.mv(effectsize ~ binge + followup + sreport + age, random = list(~ 1 | esid, ~ 1 | studyid), subset = !is.na(binge) & !is.na(followup), data = dat_miss, V = var, method = "REML") expect_error(vcovCR(hier_complete, type = "CR0", cluster = dat_miss$studyid)) CR_drop_A <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x)) CR_drop_B <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x, cluster = dat_miss$studyid)) CR_complete <- lapply(CR_types, function(x) vcovCR(hier_complete, type = x)) expect_equal(CR_drop_A, CR_complete) expect_equal(CR_drop_B, CR_complete) test_drop_A <- lapply(CR_types, function(x) coef_test(hier_drop, vcov = x, test = "All", p_values = FALSE)) test_drop_B <- lapply(CR_types, function(x) coef_test(hier_drop, vcov = x, cluster = dat_miss$studyid, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(hier_complete, vcov = x, test = "All", p_values = FALSE)) compare_ttests(test_drop_A, test_complete) compare_ttests(test_drop_B, test_complete) }) test_that("clubSandwich works with missing diagonal variances", { dat_miss <- hierdat dat_miss$var[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 10))] <- NA expect_warning(hier_drop <- rma.mv(effectsize ~ binge + followup + sreport + age, random = list(~ 1 | esid, ~ 1 | studyid), data = dat_miss, V = var, method = "REML")) hier_complete <- rma.mv(effectsize ~ binge + followup + sreport + age, random = list(~ 1 | esid, ~ 1 | studyid), subset = !is.na(var), data = dat_miss, V = var, method = "REML") expect_error(vcovCR(hier_complete, type = "CR0", cluster = dat_miss$studyid)) CR_drop_A <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x)) CR_drop_B <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x, cluster = dat_miss$studyid)) CR_complete <- lapply(CR_types, function(x) vcovCR(hier_complete, type = x)) expect_equal(CR_drop_A, CR_complete) expect_equal(CR_drop_B, CR_complete) }) test_that("clubSandwich works with missing vcov matrix", { skip_if(packageVersion("metafor") < "2.1") dat_miss <- corrdat dat_miss$var[sample.int(nrow(corrdat), size = round(nrow(corrdat) / 10))] <- NA V_missing <- impute_covariance_matrix(dat_miss$var, cluster = dat_miss$studyid, r = 0.8) expect_warning(corr_drop <- rma.mv(effectsize ~ males + college + binge, random = ~ 1 | studyid, V = V_missing, data = dat_miss)) corr_complete <- rma.mv(effectsize ~ males + college + binge, random = ~ 1 | studyid, subset = !is.na(var), data = dat_miss, V = V_missing) expect_error(vcovCR(corr_complete, type = "CR0", cluster = dat_miss$studyid)) CR_drop <- lapply(CR_types, function(x) vcovCR(corr_drop, cluster = dat_miss$studyid, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(corr_complete, type = x)) expect_equal(CR_drop, CR_complete, tolerance = 1e-5) # V_complete <- impute_covariance_matrix(corrdat$var, cluster = corrdat$studyid, r = 0.8) # W_missing <- lapply(V_complete, function(x) chol2inv(chol(x))) # # corr_drop <- rma.mv(effectsize ~ males + college + binge, # random = ~ 1 | studyid, # V = V_complete, W = bldiag(W_missing), # data = dat_miss) # # corr_complete <- rma.mv(effectsize ~ males + college + binge, # random = ~ 1 | studyid, # V = V_complete, W = bldiag(W_missing), # data = dat_miss, subset = !is.na(var)) # # expect_error(vcovCR(corr_complete, type = "CR0", cluster = dat_miss$studyid)) # # CR_drop <- lapply(CR_types, function(x) vcovCR(corr_drop, type = x)) # CR_complete <- lapply(CR_types, function(x) vcovCR(corr_complete, type = x)) # expect_equal(CR_drop, CR_complete) }) test_that("vcovCR options work for CR2", { RE_var <- targetVariance(hier_meta, cluster = factor(hierdat$studyid)) CR2_iv <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid) expect_equal(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, inverse_var = FALSE) expect_equal(CR2_not, CR2_iv) expect_equivalent(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = RE_var), CR2_not) expect_equivalent(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = RE_var, inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(hier_meta, type = "CR2", cluster = hierdat$studyid, target = hierdat$var), CR2_not)) }) test_that("clubSandwich works with complicated random effects specifications.", { skip_on_cran() data(oswald2013, package = "robumeta") oswald2013 <- within(oswald2013, { V = (1 - R^2)^2 / (N - 3) SSID = paste(Study, "sample",Sample.ID) ESID = 1:nrow(oswald2013) }) SS_lab <- unique(oswald2013$SSID) n_SS <- length(SS_lab) R_mat <- 0.4 + 0.6 * diag(nrow = n_SS) colnames(R_mat) <- rownames(R_mat) <- SS_lab m1 <- rma.mv( R ~ 0 + IAT.Focus + Crit.Cat, V = V, data = oswald2013, random = list(~ 1 | Study, ~ 1 | SSID, ~ 1 | ESID) ) m2 <- update(m1, random = list(~ IAT.Focus | Study, ~ 1 | SSID, ~ 1 | ESID), struct = c("UN")) m3 <- update(m1, random = list(~ 1 | Study, ~ IAT.Focus | SSID, ~ 1 | ESID), struct = c("UN","UN")) m4 <- update(m1, random = list(~ 1 | Study, ~ 1 | SSID, ~ IAT.Focus | ESID), struct = c("DIAG")) m5 <- update(m1, random = list(~ IAT.Focus | Study, ~ IAT.Focus | SSID), struct = c("UN","UN")) m6 <- update(m1, random = list(~ IAT.Focus | Study, ~ IAT.Focus | SSID, ~ 1 | ESID), struct = c("UN","UN")) m7 <- update(m5, struct = c("CS","CS")) m8 <- update(m5, struct = c("HCS","HCS")) m9 <- update(m5, struct = c("UN","CS")) m10 <- update(m5, struct = c("CS","UN")) m11 <- rma.mv( R ~ 0 + IAT.Focus + Crit.ID, V = V, data = oswald2013, random = list(~ 1 + Crit.ID | Study), struct = c("GEN") ) m12 <- update(m11, random = list(~ 1 + Crit.ID | Study, ~ 1 | SSID)) m13 <- update(m11, random = list(~ 1 + Crit.ID | Study, ~ IAT.Focus | SSID), struct = c("GEN","UN")) m14 <- update(m11, random = list(~ IAT.Focus | Study, ~ 1 + Crit.ID | SSID), struct = c("UN","GEN")) mod_list <- list(m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14) os_cluster <- factor(oswald2013$Study) obj <- m6 struct <- parse_structure(obj) findCluster.rma.mv(obj) cluster_list <- lapply(mod_list, findCluster.rma.mv) lapply(cluster_list, expect_equal, expected = os_cluster) bread_checks <- sapply(mod_list, check_bread, cluster = oswald2013$Study, y = oswald2013$R) expect_true(all(bread_checks)) CR_checks <- sapply(mod_list, check_CR, vcov = "CR2") expect_true(all(CR_checks)) m11 <- update(m1, R = list(SSID = R_mat)) expect_error(findCluster.rma.mv(m11)) }) test_that("clubSandwich works for random slopes model.", { # example from https://wviechtb.github.io/metadat/reference/dat.obrien2003.html dat <- dat.obrien2003 dat$bmicent <- dat$bmi - ave(dat$bmi, dat$study) dat <- escalc(measure="PR", xi=cases, ni=total, data=dat) dat$yi <- dat$yi*100 dat$vi <- dat$vi*100^2 res <- rma.mv(yi, vi, mods = ~ bmicent, random = ~ bmicent | study, struct="GEN", data=dat) cl <- findCluster.rma.mv(res) expect_true(check_bread(res, cluster = cl, y = dat$yi)) expect_true(check_CR(res, vcov = "CR2")) }) test_that("clubSandwich works for correlated hierarchical effects model.", { skip_on_cran() V_mat <- impute_covariance_matrix(vi = corrdat$var, cluster = corrdat$studyid, r = 0.7, smooth_vi = TRUE) CHE_es <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = V_mat, random = ~ 1 | esid) CHE_study <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = V_mat, random = ~ 1 | studyid) CHE_studyes <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = V_mat, random = ~ 1 | studyid / esid) CHE_esstudy <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = V_mat, random = ~ 1 | esid/ studyid) CHE_study_es <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = V_mat, random = list(~ 1 | studyid, ~ 1 | esid)) CHE_es_study <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = V_mat, random = list(~ 1 | esid, ~ 1 | studyid)) mods <- list(es = CHE_es, study = CHE_study, studyes = CHE_studyes, esstudy = CHE_esstudy, study_es = CHE_study_es, es_study = CHE_es_study) clusters <- lapply(mods, findCluster.rma.mv) expect_equal(clusters$study, clusters$studyes) expect_equal(clusters$es, clusters$esstudy) expect_equal(clusters$studyes, clusters$study_es) expect_equal(clusters$study_es, clusters$es_study) V_CR2s <- lapply(mods, vcovCR, type = "CR2") V_CR2s_clust <- mapply(vcovCR, mods, clusters, type = "CR2", SIMPLIFY = FALSE) expect_equal(V_CR2s, V_CR2s_clust) expect_equal(V_CR2s$studyes, V_CR2s$study_es) expect_equal(V_CR2s$studyes, V_CR2s$es_study) }) test_that("vcovCR errors when there is only one cluster.", { dat <- data.frame( study = "study1", # study number est = runif(5, 0.1, 0.6), # R-squared values se = runif(5, 0.005, 0.025), # standard errors of R-squared values es_id = 1:5 # effect size ID ) v_mat <- impute_covariance_matrix(dat$se^2, cluster = dat$study, r = 0.8) # working model in metafor expect_warning( res <- rma.mv(yi = est, V = v_mat, random = ~ 1 | study / es_id, data = dat) ) single_cluster_error_msg <- "Cluster-robust variance estimation will not work when the data only includes a single cluster." expect_error( vcovCR(res, type = "CR0"), single_cluster_error_msg ) expect_error( conf_int(res, vcov = "CR1"), single_cluster_error_msg ) expect_error( coef_test(res, vcov = "CR2"), single_cluster_error_msg ) expect_error( Wald_test(res, constraints = constrain_zero(1), vcov = "CR3"), single_cluster_error_msg ) expect_error( vcovCR(res, cluster = dat$es_id), "Random effects are not nested within clustering variable." ) }) test_that("clubSandwich works when random effects variable has missing levels.",{ dat <- dat.konstantopoulos2011 dat$district_fac <- factor(dat$district) dat$district_fac_plus <- factor(dat$district, levels = c(levels(dat$district_fac), 1000, 10000)) mlma_fac <- rma.mv(yi ~ year, V = vi, random = ~ 1 | district_fac / study, sparse = TRUE, data = dat) implicit_fac <- coef_test(mlma_fac, vcov = "CR2") explicit_fac <- coef_test(mlma_fac, vcov = "CR2", cluster = dat$district_fac) expect_equal(implicit_fac, explicit_fac) mlma_plus <- rma.mv(yi ~ year, V = vi, random = ~ 1 | district_fac_plus / study, sparse = TRUE, data = dat) implicit_plus <- coef_test(mlma_plus, vcov = "CR2") explicit_plus <- coef_test(mlma_plus, vcov = "CR2", cluster = dat$district_fac_plus) expect_equal(implicit_plus, explicit_plus) expect_equal(implicit_fac, implicit_plus) expect_equal(implicit_fac, explicit_plus) mlma_num <- rma.mv(yi ~ year, V = vi, random = ~ 1 | district / study, sparse = TRUE, data = dat) implicit_num <- coef_test(mlma_num, vcov = "CR2") explicit_num <- coef_test(mlma_num, vcov = "CR2", cluster = dat$district) expect_equal(implicit_num, explicit_num) expect_equal(implicit_fac, implicit_num) expect_equal(implicit_fac, explicit_num) }) Vmat <- with(corrdat, impute_covariance_matrix(vi = var, cluster = studyid, r = 0.8)) corr_meta <- rma.mv(effectsize ~ males + college + binge, data = corrdat, V = Vmat, random = ~ 1 | studyid) test_that("clubSandwich agrees with metafor::robust() for CR0.", { test_CR0 <- coef_test(corr_meta, vcov = "CR0", test = "All") meta_CR0 <- robust(corr_meta, cluster = corrdat$studyid, adjust = FALSE) rob_CR0 <- coef_test(meta_CR0, vcov = "CR0", test = "All") expect_equal(test_CR0$SE, meta_CR0$se) expect_equal(test_CR0$df_tp, rep(meta_CR0$df, length(test_CR0$df_tp))) expect_equal(test_CR0$p_tp, meta_CR0$pval, tolerance = 1e-5) compare_ttests(rob_CR0, test_CR0, tol = 1e-6) club_F_CR0 <- Wald_test(corr_meta, constraints = constrain_zero(2:4), vcov = "CR0", test = "Naive-Fp") rob_F_CR0 <- Wald_test(meta_CR0, constraints = constrain_zero(2:4), vcov = "CR0", test = "Naive-Fp") expect_equal(club_F_CR0$Fstat, meta_CR0$QM) expect_equal(club_F_CR0$df_num, meta_CR0$QMdf[1]) expect_equal(club_F_CR0$df_denom, meta_CR0$QMdf[2]) expect_equal(club_F_CR0$p_val, meta_CR0$QMp, tolerance = 1e-5) compare_Waldtests(club_F_CR0, rob_F_CR0, tol = 1e-5) }) test_that("clubSandwich agrees with metafor::robust() for CR1p.", { test_CR1 <- coef_test(corr_meta, vcov = "CR1p", test = "All") meta_CR1 <- robust(corr_meta, cluster = corrdat$studyid, adjust = TRUE) rob_CR1 <- coef_test(meta_CR1, vcov = "CR1p", test = "All") expect_equal(test_CR1$SE, meta_CR1$se) expect_equal(test_CR1$df_tp, rep(meta_CR1$df, length(test_CR1$df_tp))) expect_equal(test_CR1$p_tp, meta_CR1$pval, tolerance = 1e-5) compare_ttests(rob_CR1, test_CR1, tol = 1e-5) club_F_CR1 <- Wald_test(corr_meta, constraints = constrain_zero(2:4), vcov = "CR1p", test = "Naive-Fp") rob_F_CR1 <- Wald_test(meta_CR1, constraints = constrain_zero(2:4), vcov = "CR1p", test = "Naive-Fp") expect_equal(club_F_CR1$Fstat, meta_CR1$QM) expect_equal(club_F_CR1$df_num, meta_CR1$QMdf[1]) expect_equal(club_F_CR1$df_denom, meta_CR1$QMdf[2]) expect_equal(club_F_CR1$p_val, meta_CR1$QMp, tolerance = 1e-5) compare_Waldtests(club_F_CR1, rob_F_CR1, tol = 1e-5) }) test_that("clubSandwich agrees with metafor::robust() for CR2.", { skip_if(packageVersion('metafor') < "3.1.31") test_CR2 <- coef_test(corr_meta, vcov = "CR2", test = "All") meta_CR2 <- robust(corr_meta, cluster = corrdat$studyid, clubSandwich = TRUE) rob_CR2 <- coef_test(meta_CR2, vcov = "CR2", test = "All") expect_equal(test_CR2$SE, meta_CR2$se) compare_ttests(rob_CR2, test_CR2, tol = 1e-5) club_F_CR2 <- Wald_test(corr_meta, constraints = constrain_zero(2:4), vcov = "CR2", test = "All") rob_F_CR2 <- Wald_test(meta_CR2, constraints = constrain_zero(2:4), vcov = "CR2", test = "All") expect_equal(subset(club_F_CR2, test == "HTZ")$Fstat, meta_CR2$QM) expect_equal(subset(club_F_CR2, test == "HTZ")$df_num, meta_CR2$QMdf[1]) expect_equal(subset(club_F_CR2, test == "HTZ")$df_denom, meta_CR2$QMdf[2]) expect_equal(subset(club_F_CR2, test == "HTZ")$p_val, meta_CR2$QMp, tolerance = 1e-5) compare_Waldtests(club_F_CR2, rob_F_CR2, tol = 1e-5) }) test_that("clubSandwich methods work on robust.rma objects.", { hier_robust <- robust(hier_meta, cluster = hierdat$studyid, adjust = TRUE) expect_equal(residuals_CS(hier_meta), residuals_CS(hier_robust)) expect_equal(coef_CS(hier_meta), coef_CS(hier_robust)) expect_equal(model_matrix(hier_meta), model_matrix(hier_robust)) expect_equal(bread(hier_meta), bread(hier_robust)) expect_equal(v_scale(hier_meta), v_scale(hier_robust)) expect_equal(targetVariance(hier_meta, cluster = hierdat$studyid), targetVariance(hier_robust, cluster = hierdat$studyid)) expect_equal(weightMatrix(hier_meta, cluster = hierdat$studyid), weightMatrix(hier_robust, cluster = hierdat$studyid)) hier_club <- robust(hier_meta, cluster = hierdat$studyid, adjust = FALSE, clubSandwich = TRUE) expect_equal(residuals_CS(hier_meta), residuals_CS(hier_club)) expect_equal(coef_CS(hier_meta), coef_CS(hier_club)) expect_equal(model_matrix(hier_meta), model_matrix(hier_club)) expect_equal(bread(hier_meta), bread(hier_club)) expect_equal(v_scale(hier_meta), v_scale(hier_club)) expect_equal(targetVariance(hier_meta, cluster = hierdat$studyid), targetVariance(hier_club, cluster = hierdat$studyid)) expect_equal(weightMatrix(hier_meta, cluster = hierdat$studyid), weightMatrix(hier_club, cluster = hierdat$studyid)) }) test_that("clubSandwich works with user-weighted rma.mv objects.", { data("oswald2013", package = "robumeta") oswald2013$yi <- atanh(oswald2013$R) oswald2013$vi <- 1 / (oswald2013$N - 3) oswald2013$esID <- 1:nrow(oswald2013) oswald2013$wt <- 1 + rpois(nrow(oswald2013), lambda = 1) V <- impute_covariance_matrix(vi = oswald2013$vi, cluster = oswald2013$Study, r = 0.4) mod_wt1 <- rma.mv(yi ~ 0 + Crit.Cat + Crit.Domain + IAT.Focus + Scoring, V = V, W = wt, random = ~ 1 | Study, data = oswald2013, sparse = TRUE) W_mat <- impute_covariance_matrix(vi = oswald2013$wt, cluster = oswald2013$Study, r = 0, return_list = FALSE) mod_wt2 <- rma.mv(yi ~ 0 + Crit.Cat + Crit.Domain + IAT.Focus + Scoring, V = V, W = W_mat, random = ~ 1 | Study, data = oswald2013, sparse = TRUE) vcovs_1 <- lapply(CR_types, function(x) vcovCR(mod_wt1, type = x)) vcovs_2 <- lapply(CR_types, function(x) vcovCR(mod_wt2, type = x)) coef_test_wt1 <- lapply(CR_types, function(x) coef_test(mod_wt1, vcov = x, test = "All") ) coef_test_wt2 <- lapply(CR_types, function(x) coef_test(mod_wt2, vcov = x, test = "All") ) Wald_test_wt1 <- lapply(CR_types, function(x) Wald_test(mod_wt1, constraints = constrain_equal("Crit.Cat", reg_ex = TRUE), vcov = x, test = "All") ) Wald_test_wt2 <- lapply(CR_types, function(x) Wald_test(mod_wt2, constraints = constrain_equal("Crit.Cat", reg_ex = TRUE), vcov = x, test = "All") ) expect_equal(vcovs_1, vcovs_2, tolerance = 1e-5) compare_ttests(coef_test_wt1, coef_test_wt2, tol = 1e-5) compare_Waldtests(Wald_test_wt1, Wald_test_wt2, tol = 1e-5) for (i in seq_along(vcovs_1)) { expect_s3_class(vcovs_1[[i]], "vcovCR") expect_s3_class(vcovs_2[[i]], "vcovCR") expect_s3_class(coef_test_wt1[[i]], "coef_test_clubSandwich") expect_s3_class(coef_test_wt2[[i]], "coef_test_clubSandwich") expect_s3_class(Wald_test_wt1[[i]], "Wald_test_clubSandwich") expect_s3_class(Wald_test_wt2[[i]], "Wald_test_clubSandwich") } }) clubSandwich/tests/testthat/test_lme_3level.R0000644000176200001440000002174114630154052021100 0ustar liggesuserscontext("3-level lme objects") set.seed(20190513) # skip_if_not_installed("lme4") skip_if_not_installed("nlme") skip_if_not_installed("mlmRev") # suppressMessages(library(lme4, quietly=TRUE)) library(nlme, quietly=TRUE, warn.conflicts=FALSE) library(mlmRev, quietly=TRUE, warn.conflicts=FALSE) school_subset <- levels(egsingle$schoolid) school_subset <- sample(school_subset, size = 15) egsingle <- droplevels(subset(egsingle, schoolid %in% school_subset)) obj_A1 <- lme(math ~ year * size + female + black + hispanic, random = list(~ year | schoolid, ~ 1 | childid), data = egsingle, control = lmeControl(tolerance = 1e-4, opt = "optim")) obj_A2 <- update(obj_A1, weights = varIdent(form = ~ 1 | female)) obj_A3 <- update(obj_A1, correlation = corExp(form = ~ year)) obj_A4 <- update(obj_A2, correlation = corExp(form = ~ year)) objects <- list(A1 = obj_A1, A2 = obj_A2, A3 = obj_A3, A4 = obj_A4) CR2_mats <- lapply(objects, vcovCR, type = "CR2") test_that("bread works", { bread_checks <- lapply(objects, check_bread, cluster = egsingle$schoolid, y = egsingle$math) expect_true(all(unlist(bread_checks))) obj_vcovs <- lapply(objects, vcov) obj_bread <- lapply(objects, function(obj) obj$sigma^2 * sandwich::bread(obj) / v_scale(obj)) expect_equal(obj_vcovs, obj_bread) }) test_that("vcovCR options work for CR2", { skip_on_cran() expect_equal(vcovCR(obj_A1, cluster = egsingle$schoolid, type = "CR2"), CR2_mats[["A1"]]) expect_equal(vcovCR(obj_A1, type = "CR2", inverse_var = TRUE), CR2_mats[["A1"]]) expect_false(identical(vcovCR(obj_A1, type = "CR2", inverse_var = FALSE), CR2_mats[["A1"]])) target <- targetVariance(obj_A1) expect_equal(vcovCR(obj_A1, type = "CR2", target = target, inverse_var = TRUE), CR2_mats[["A1"]]) attr(CR2_mats[["A1"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A1, type = "CR2", target = target, inverse_var = FALSE), CR2_mats[["A1"]]) expect_equal(vcovCR(obj_A2, cluster = egsingle$schoolid, type = "CR2"), CR2_mats[["A2"]]) expect_equal(vcovCR(obj_A2, type = "CR2", inverse_var = TRUE), CR2_mats[["A2"]]) expect_false(identical(vcovCR(obj_A2, type = "CR2", inverse_var = FALSE), CR2_mats[["A2"]])) target <- targetVariance(obj_A2) expect_equal(vcovCR(obj_A2, type = "CR2", target = target, inverse_var = TRUE), CR2_mats[["A2"]]) attr(CR2_mats[["A2"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A2, type = "CR2", target = target, inverse_var = FALSE), CR2_mats[["A2"]]) expect_equal(vcovCR(obj_A3, cluster = egsingle$schoolid, type = "CR2"), CR2_mats[["A3"]]) expect_equal(vcovCR(obj_A3, type = "CR2", inverse_var = TRUE), CR2_mats[["A3"]]) expect_false(identical(vcovCR(obj_A3, type = "CR2", inverse_var = FALSE), CR2_mats[["A3"]])) target <- targetVariance(obj_A3) expect_equal(vcovCR(obj_A3, type = "CR2", target = target, inverse_var = TRUE), CR2_mats[["A3"]]) attr(CR2_mats[["A3"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A3, type = "CR2", target = target, inverse_var = FALSE), CR2_mats[["A3"]]) expect_equal(vcovCR(obj_A4, cluster = egsingle$schoolid, type = "CR2"), CR2_mats[["A4"]]) expect_equal(vcovCR(obj_A4, type = "CR2", inverse_var = TRUE), CR2_mats[["A4"]]) expect_false(identical(vcovCR(obj_A4, type = "CR2", inverse_var = FALSE), CR2_mats[["A4"]])) target <- targetVariance(obj_A4) expect_equal(vcovCR(obj_A4, type = "CR2", target = target, inverse_var = TRUE), CR2_mats[["A4"]]) attr(CR2_mats[["A4"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A4, type = "CR2", target = target, inverse_var = FALSE), CR2_mats[["A4"]]) }) test_that("vcovCR options work for CR4", { skip_on_cran() skip("Not worrying about CR4 for now.") CR4_mats <- lapply(objects, vcovCR, type = "CR4") expect_equal(vcovCR(obj_A1, cluster = egsingle$schoolid, type = "CR4"), CR4_mats[["A1"]]) expect_equal(vcovCR(obj_A1, type = "CR4", inverse_var = TRUE), CR4_mats[["A1"]]) expect_false(identical(vcovCR(obj_A1, type = "CR4", inverse_var = FALSE), CR4_mats[["A1"]])) target <- targetVariance(obj_A1) expect_equal(vcovCR(obj_A1, type = "CR4", target = target, inverse_var = TRUE), CR4_mats[["A1"]]) attr(CR4_mats[["A1"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A1, type = "CR4", target = target, inverse_var = FALSE), CR4_mats[["A1"]]) expect_equal(vcovCR(obj_A2, cluster = egsingle$schoolid, type = "CR4"), CR4_mats[["A2"]]) expect_equal(vcovCR(obj_A2, type = "CR4", inverse_var = TRUE), CR4_mats[["A2"]]) expect_false(identical(vcovCR(obj_A2, type = "CR4", inverse_var = FALSE), CR4_mats[["A2"]])) target <- targetVariance(obj_A2) expect_equal(vcovCR(obj_A2, type = "CR4", target = target, inverse_var = TRUE), CR4_mats[["A2"]]) attr(CR4_mats[["A2"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A2, type = "CR4", target = target, inverse_var = FALSE), CR4_mats[["A2"]]) expect_equal(vcovCR(obj_A3, cluster = egsingle$schoolid, type = "CR4"), CR4_mats[["A3"]]) expect_equal(vcovCR(obj_A3, type = "CR4", inverse_var = TRUE), CR4_mats[["A3"]]) expect_false(identical(vcovCR(obj_A3, type = "CR4", inverse_var = FALSE), CR4_mats[["A3"]])) target <- targetVariance(obj_A3) expect_equal(vcovCR(obj_A3, type = "CR4", target = target, inverse_var = TRUE), CR4_mats[["A3"]]) attr(CR4_mats[["A3"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A3, type = "CR4", target = target, inverse_var = FALSE), CR4_mats[["A3"]]) expect_equal(vcovCR(obj_A4, cluster = egsingle$schoolid, type = "CR4"), CR4_mats[["A4"]]) expect_equal(vcovCR(obj_A4, type = "CR4", inverse_var = TRUE), CR4_mats[["A4"]]) expect_false(identical(vcovCR(obj_A4, type = "CR4", inverse_var = FALSE), CR4_mats[["A4"]])) target <- targetVariance(obj_A4) expect_equal(vcovCR(obj_A4, type = "CR4", target = target, inverse_var = TRUE), CR4_mats[["A4"]]) attr(CR4_mats[["A4"]], "inverse_var") <- FALSE expect_equal(vcovCR(obj_A4, type = "CR4", target = target, inverse_var = FALSE), CR4_mats[["A4"]]) }) test_that("CR2 is target-unbiased", { skip_on_cran() CR2_checks <- mapply(check_CR, obj = objects, vcov = CR2_mats) expect_true(all(CR2_checks)) # CR4_checks <- mapply(check_CR, obj = objects, vcov = CR4_mats) # expect_true(all(CR4_checks)) }) CR_types <- paste0("CR",0:3) test_that("Order doesn't matter.", { skip_on_cran() check_sort_order(obj_A1, egsingle) check_sort_order(obj_A2, egsingle) check_sort_order(obj_A3, egsingle) check_sort_order(obj_A4, egsingle) }) test_that("clubSandwich works with dropped observations", { skip_on_cran() dat_miss <- egsingle dat_miss$math[sample.int(nrow(egsingle), size = round(nrow(egsingle) / 10))] <- NA obj_dropped <- update(obj_A4, data = dat_miss, na.action = na.omit) obj_complete <- update(obj_A4, data = dat_miss, subset = !is.na(math)) # obj <- obj_dropped # cluster <- nlme::getGroups(obj, level = 1) # target <- NULL # inverse_var <- TRUE # type <- "CR2" # form <- "sandwich" # # full_grps <- get_cor_grouping(obj) # R_list <- nlme::corMatrix(obj$modelStruct$corStruct) # levels <- names(R_list) # grps <- get_cor_grouping(obj, levels = names(R_list)) # # V_list <- build_var_cor_mats(obj) # V_grps <- attr(V_list, "groups") # ZDZ_list <- build_RE_mats(obj) # ZDZ_grps <- attr(ZDZ_list, "groups") # # V_dim <- sapply(V_list, nrow) # identical(names(V_dim), names(table(V_grps))) # data.frame(dim = V_dim, grps = table(V_grps)) # table(V_dim == table(V_grps)) # dat_miss$x <- NA # dat_miss$x[!is.na(dat_miss$math)] <- V_grps CR_drop <- lapply(CR_types, function(x) vcovCR(obj_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(obj_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_drop, function(x) coef_test(obj_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_complete, function(x) coef_test(obj_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("Possible to cluster at higher level than random effects", { skip_on_cran() # fit two-level model obj_2level <- lme(math ~ year * size + female + black + hispanic, random = ~ year | childid, data = egsingle) # cluster at level 3 V <- vcovCR(obj_2level, type = "CR2", cluster = egsingle$schoolid) expect_is(V, "vcovCR") # create 4th level n_districts <- nlevels(egsingle$schoolid) / 3 districtid <- rep(1:n_districts, each = 3)[egsingle$schoolid] # cluster at level 4 expect_is(vcovCR(obj_2level, type = "CR2", cluster = districtid), "vcovCR") expect_is(vcovCR(obj_A1, type = "CR2", cluster = districtid), "vcovCR") expect_is(vcovCR(obj_A2, type = "CR2", cluster = districtid), "vcovCR") expect_is(vcovCR(obj_A3, type = "CR2", cluster = districtid), "vcovCR") expect_is(vcovCR(obj_A4, type = "CR2", cluster = districtid), "vcovCR") }) clubSandwich/tests/testthat/test_coef.R0000644000176200001440000001047214630154052017764 0ustar liggesuserscontext("t-tests") set.seed(20190513) balanced_dat <- function(m, n) { cluster <- factor(rep(LETTERS[1:m], each = n)) N <- length(cluster) m1 <- sample(3:(m-7), size = 1) m2 <- sample((m1 + 3):(m-3), size = 1) - m1 m3 <- m - m1 - m2 c(m1, m2, m3) X_btw <- rep(rep(LETTERS[1:3], c(m1, m2, m3)), each = n) X_wth <- rep(rep(c(0,1), each = n / 2), m) nu <- rnorm(m)[cluster] e <- rnorm(n * m) y <- nu + e data.frame(y, X_btw, X_wth, cluster, row = 1:N) } CRs <- paste0("CR", 0:4) test_that("vcov arguments work", { dat <- balanced_dat(m = 15, n = 8) lm_fit <- lm(y ~ X_btw + X_wth, data = dat) VCR <- lapply(CRs, function(t) vcovCR(lm_fit, cluster = dat$cluster, type = t)) test_A <- lapply(VCR, function(v) coef_test(lm_fit, vcov = v, test = "All", p_values = FALSE)) test_B <- lapply(CRs, function(t) coef_test(lm_fit, vcov = t, cluster = dat$cluster, test = "All", p_values = FALSE)) compare_ttests(test_A, test_B) }) test_that("get_which_coef() works", { f <- 6 beta <- 1:f beta_names <- letters[1:f] names(beta) <- beta_names which_grid <- as.matrix(expand.grid(rep(list(c(FALSE,TRUE)), f))) dimnames(which_grid) <- NULL name_list <- apply(which_grid, 1, function(x) beta_names[x]) int_list <- apply(which_grid, 1, which) which_log <- apply(which_grid[-1,], 1, get_which_coef, beta = beta) which_char <- sapply(name_list[-1], get_which_coef, beta = beta) which_int <- sapply(int_list[-1], get_which_coef, beta = beta) expect_identical(get_which_coef(beta, coefs = "All"), rep(TRUE, f)) expect_error(get_which_coef(beta, coefs = which_grid[1,])) expect_error(get_which_coef(beta, coefs = name_list[[1]])) expect_error(get_which_coef(beta, coefs = int_list[[1]])) expect_identical(which_log, which_char) expect_identical(which_log, which_int) expect_identical(which_char, which_int) }) test_that("coefs argument works", { dat <- balanced_dat(m = 15, n = 8) lm_fit <- lm(y ~ X_btw + X_wth, data = dat) which_grid <- expand.grid(rep(list(c(FALSE,TRUE)), length(coef(lm_fit)))) tests_all <- coef_test(lm_fit, vcov = "CR0", cluster = dat$cluster, test = "All", coefs = "All", p_values = FALSE) tests_A <- apply(which_grid[-1,], 1, function(x) tests_all[x,]) tests_B <- apply(which_grid[-1,], 1, function(x) coef_test(lm_fit, vcov = "CR0", cluster = dat$cluster, test = "All", coefs = x, p_values = FALSE)) expect_equal(tests_A, tests_B, check.attributes = FALSE) }) test_that("printing works", { dat <- balanced_dat(m = 15, n = 8) lm_fit <- lm(y ~ X_btw + X_wth, data = dat) t_tests <- coef_test(lm_fit, vcov = "CR2", cluster = dat$cluster, test = "All") expect_output(x <- print(t_tests)) expect_equal(t_tests$df_z, rep(Inf, 4L)) expect_equal(t_tests$df_t, rep(14L, 4L)) expect_true(all(t_tests$df_t >= round(t_tests$df_Satt,1))) expect_identical(names(x), c("Coef.","Estimate","SE","t-stat", "d.f. (z)", "p-val (z)", "Sig.", "d.f. (naive-t)", "p-val (naive-t)","Sig.", "d.f. (naive-tp)", "p-val (naive-tp)","Sig.", "d.f. (Satt)", "p-val (Satt)", "Sig.", "s.p.", "p-val (Saddle)", "Sig.")) }) test_that("p-values are ordered", { dat <- balanced_dat(m = 15, n = 8) lm_fit <- lm(y ~ X_btw + X_wth, data = dat) test_results <- lapply(CRs, function(t) coef_test(lm_fit, vcov = t, cluster = dat$cluster, test = "All")) test_results <- do.call(rbind, test_results) expect_true(with(test_results, all(p_z < p_t))) expect_true(with(test_results, all(p_z < p_Satt))) }) test_that("Satterthwaite df work for special cases", { m <- sample(12:26, size = 1) n <- sample(seq(4,12,2), size = 1) dat <- balanced_dat(m, n) lm_fit <- lm(y ~ X_btw + X_wth, data = dat) t_tests <- coef_test(lm_fit, vcov = "CR2", cluster = dat$cluster, test = "Satterthwaite") expect_equal(t_tests$df[4], m - 1) mg <- table(dat$X_btw) / n df <- apply(cbind(mg[1], mg[-1]), 1, function(x) sum(x)^2 * prod(x - 1) / sum(x^2 * (x - 1))) expect_equivalent(t_tests$df[2:3], df) lm_fit <- lm(y ~ 0 + cluster + X_wth, data = dat) t_tests <- coef_test(lm_fit, vcov = "CR2", cluster = dat$cluster, test = "Satterthwaite") expect_equal(t_tests$df[m + 1], m - 1) }) clubSandwich/tests/testthat/test_plm-random-effects.R0000644000176200001440000002511614630154052022534 0ustar liggesuserscontext("plm objects - random effects") set.seed(20190513) skip_if_not_installed("nlme") skip_if_not_installed("plm") library(nlme, quietly=TRUE) library(plm, quietly=TRUE) data("Grunfeld", package = "plm") data("Produc", package = "plm") # grun_re <- plm(inv ~ value + capital, data = Grunfeld, model="random") # Grunfeld$cluster <- sample(LETTERS[1:10], size = nrow(Grunfeld), replace=TRUE) # Grunfeld_scramble <- Grunfeld[sample(nrow(Grunfeld)),] CR_types <- paste0("CR",0:4) plm_individual <- plm(inv ~ value + capital, data = Grunfeld, model="random") obj <- plm_individual test_that("individual effects agree with gls", { icc <- with(plm_individual$ercomp, sigma2[["id"]] / (sigma2[["id"]] + sigma2[["idios"]])) gls_individual <- gls(inv ~ value + capital, data = Grunfeld, correlation = corCompSymm(value = icc, form = ~ 1 | firm, fixed=TRUE)) expect_equal(model_matrix(plm_individual), model_matrix(gls_individual)) expect_identical(nobs(plm_individual), nobs(gls_individual)) V_ratio <- Map("/", targetVariance(plm_individual, cluster = Grunfeld$firm), targetVariance(gls_individual, cluster = Grunfeld$firm)) expect_equal(lapply(V_ratio, min), lapply(V_ratio, max)) expect_equivalent(residuals_CS(plm_individual), residuals_CS(gls_individual)) CR_plm <- lapply(CR_types, function(x) vcovCR(plm_individual, type = x)) CR_gls <- lapply(CR_types, function(x) vcovCR(gls_individual, type = x)) expect_equivalent(CR_plm, CR_gls) test_plm <- lapply(CR_types, function(x) coef_test(plm_individual, vcov = x, test = "All", p_values = FALSE)[,-3]) test_gls <- lapply(CR_types, function(x) coef_test(gls_individual, vcov = x, test = "All", p_values = FALSE)[,-3]) expect_equivalent(test_plm, test_gls) }) plm_time <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year"), effect = "time", model = "random") test_that("time effects agree with gls", { icc <- with(plm_time$ercomp, sigma2[[2]] / (sigma2[[2]] + sigma2[[1]])) gls_time <- gls(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, correlation = corCompSymm(value = icc, form = ~ 1 | year, fixed = TRUE)) expect_equal(model_matrix(plm_time), model_matrix(gls_time)) expect_identical(nobs(plm_time), nobs(gls_time)) expect_equivalent(residuals_CS(plm_time), residuals_CS(gls_time)) CR_plm <- lapply(CR_types, function(x) vcovCR(plm_time, type = x)) CR_gls <- lapply(CR_types, function(x) vcovCR(gls_time, type = x)) expect_equivalent(CR_plm, CR_gls) test_plm <- lapply(CR_types, function(x) coef_test(plm_time, vcov = x, test = "All", p_values = FALSE)[,-3]) test_gls <- lapply(CR_types, function(x) coef_test(gls_time, vcov = x, test = "All", p_values = FALSE)[,-3]) expect_equivalent(test_plm, test_gls) }) plm_twoways <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year"), effect = "twoways", model = "random") test_that("two-way effects throws error", { expect_error(vcovCR(plm_twoways, type = "CR2")) }) plm_nested <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "nested", model = "random") test_that("nested effects agree with lmer", { skip_if_not_installed("lme4") library(lme4, quietly=TRUE) Produc_sort_order <- with(Produc, order(region, state)) plm_nested$ercomp$sigma2 lmer_nested_fit <- lmer(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp + (1 | region / state), data = Produc) theta <- getME(lmer_nested_fit, "theta") theta[1:2] <- with(plm_nested$ercomp, sqrt(sigma2[2:3] / sigma2[1])) lmer_nested <- update(lmer_nested_fit, start = theta, control = lmerControl(optimizer = NULL)) expect_equivalent(model_matrix(plm_nested), model_matrix(lmer_nested)[Produc_sort_order,]) expect_identical(nobs(plm_nested), nobs(lmer_nested)) expect_equivalent(targetVariance(plm_nested, cluster = findCluster.plm(plm_nested)), targetVariance(lmer_nested, cluster = Produc$region)) expect_equivalent(weightMatrix(plm_nested, cluster = findCluster.plm(plm_nested)), weightMatrix(lmer_nested, cluster = Produc$region), tol = 1e-6) CR_plm <- lapply(CR_types, function(x) vcovCR(plm_nested, type = x)) CR_lmer <- lapply(CR_types, function(x) vcovCR(lmer_nested, type = x)) expect_equivalent(CR_plm, CR_lmer) test_plm <- lapply(CR_types, function(x) coef_test(plm_nested, vcov = x, test = "All", p_values = FALSE)[,-3]) test_lmer <- lapply(CR_types, function(x) coef_test(lmer_nested, vcov = x, test = "All", p_values = FALSE)[,-3]) compare_ttests(test_plm, test_lmer, tol = 1e-5) }) test_that("bread works", { expect_true(check_bread(plm_individual, cluster = findCluster.plm(plm_individual), y = plm_individual$model$inv)) expect_true(check_bread(plm_time, cluster = findCluster.plm(plm_time), y = plm_time$model$"log(gsp)")) expect_true(check_bread(plm_nested, cluster = findCluster.plm(plm_nested), y = plm_nested$model$"log(gsp)")) }) test_that("CR0 and CR1S agree with arellano vcov", { expect_equivalent(vcovHC(plm_individual, method="arellano", type = "HC0", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR0"))) expect_equivalent(vcovHC(plm_individual, method="arellano", type = "sss", cluster = "group"), as.matrix(vcovCR(plm_individual, type = "CR1S"))) expect_equivalent(vcovHC(plm_time, method="arellano", type = "HC0", cluster = "time"), as.matrix(vcovCR(plm_time, type = "CR0"))) expect_equivalent(vcovHC(plm_time, method="arellano", type = "sss", cluster = "time"), as.matrix(vcovCR(plm_time, type = "CR1S"))) # Can't replicate vcovHC because plm isn't clustering correctly. # expect_equivalent(vcovHC(plm_nested, method="arellano", type = "HC0", cluster = "group"), # as.matrix(vcovCR(plm_nested, type = "CR0"))) # expect_equivalent(vcovHC(plm_nested, method="arellano", type = "sss", cluster = "group"), # as.matrix(vcovCR(plm_nested, type = "CR1S"))) }) test_that("vcovCR options work for CR2", { CR2_iv <- vcovCR(plm_individual, type = "CR2") expect_equal(vcovCR(plm_individual, cluster = Grunfeld$firm, type = "CR2"), CR2_iv) expect_equal(vcovCR(plm_individual, type = "CR2", inverse_var = TRUE), CR2_iv) tgt <- targetVariance(plm_individual, cluster = Grunfeld$firm) expect_equivalent(vcovCR(plm_individual, type = "CR2", target = tgt, inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(plm_individual, type = "CR2", inverse_var = FALSE) expect_equivalent(CR2_not, CR2_iv) expect_equal(vcovCR(plm_individual, cluster = Grunfeld$firm, type = "CR2", inverse_var = FALSE), CR2_not) expect_equal(vcovCR(plm_individual, type = "CR2", target = tgt), CR2_not) expect_equal(vcovCR(plm_individual, type = "CR2", target = tgt, inverse_var = FALSE), CR2_not) }) test_that("vcovCR options work for CR4", { CR4_iv <- vcovCR(plm_individual, type = "CR4") expect_equal(vcovCR(plm_individual, cluster = Grunfeld$firm, type = "CR4"), CR4_iv) expect_equal(vcovCR(plm_individual, type = "CR4", inverse_var = TRUE), CR4_iv) tgt <- targetVariance(plm_individual, cluster = Grunfeld$firm) expect_equivalent(vcovCR(plm_individual, type = "CR4", target = tgt, inverse_var = TRUE), CR4_iv) CR4_not <- vcovCR(plm_individual, type = "CR4", inverse_var = FALSE) expect_equivalent(CR4_not, CR4_iv) expect_equal(vcovCR(plm_individual, cluster = Grunfeld$firm, type = "CR4", inverse_var = FALSE), CR4_not) expect_equal(vcovCR(plm_individual, type = "CR4", target = tgt), CR4_not) expect_equal(vcovCR(plm_individual, type = "CR4", target = tgt, inverse_var = FALSE), CR4_not) }) test_that("CR2 and CR4 are target-unbiased", { expect_true(check_CR(plm_individual, vcov = "CR2")) expect_true(check_CR(plm_individual, vcov = "CR4")) expect_true(check_CR(plm_time, vcov = "CR2")) expect_true(check_CR(plm_time, vcov = "CR4")) expect_true(check_CR(plm_nested, vcov = "CR2")) expect_true(check_CR(plm_nested, vcov = "CR4")) }) test_that("vcovCR works when clustering at a level above the random effects.", { data("Wages", package = "plm") Wages$ID <- rep(1:595, each = 7) Wages$period <- rep(1:7, times = 595) Wages$Grp <- rep(1:119, each = 7 * 5) plm_ID <- plm(lwage ~ wks + south + smsa + married + exp, data = Wages, index = c("ID","period","Grp"), model="random") ICC <- with(plm_ID$ercomp, sigma2[2] / sum(sigma2)) gls_ID <- gls(lwage ~ wks + south + smsa + married + exp, data = Wages, correlation = corCompSymm(value = ICC, form = ~ 1 | ID, fixed = TRUE)) plm_vcov_ID <- lapply(CR_types, function(x) vcovCR(plm_ID, type = x)) gls_vcov_ID <- lapply(CR_types, function(x) vcovCR(gls_ID, type = x)) expect_equivalent(plm_vcov_ID, gls_vcov_ID) plm_vcov_grp <- lapply(CR_types, function(x) vcovCR(plm_ID, cluster = Wages$Grp, type = x)) plm_vcov_group <- lapply(CR_types, function(x) vcovCR(plm_ID, cluster = "group", type = x)) expect_equal(plm_vcov_grp, plm_vcov_group) gls_vcov_grp <- lapply(CR_types, function(x) vcovCR(gls_ID, cluster = Wages$Grp, type = x)) expect_equivalent(plm_vcov_group, gls_vcov_grp) plm_ID <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "individual", model = "random") ICC <- with(plm_ID$ercomp, sigma2[2] / sum(sigma2)) gls_ID <- gls(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, correlation = corCompSymm(value = ICC, form = ~ 1 | state, fixed = TRUE)) plm_vcov_grp <- lapply(CR_types, function(x) vcovCR(plm_ID, cluster = Produc$region, type = x)) plm_vcov_group <- lapply(CR_types, function(x) vcovCR(plm_ID, cluster = "group", type = x)) expect_equal(plm_vcov_grp, plm_vcov_group) gls_vcov_grp <- lapply(CR_types, function(x) vcovCR(gls_ID, cluster = Produc$region, type = x)) expect_equivalent(plm_vcov_grp, gls_vcov_grp) }) clubSandwich/tests/testthat/test_robu.R0000644000176200001440000004465714630154052020033 0ustar liggesuserscontext("robu objects") set.seed(20190513) skip_if_not_installed("robumeta") library(robumeta, quietly=TRUE) data(corrdat) test_that("methods work with intercept-only model.", { obj <- robu(effectsize ~ 1, studynum = studyid, var.eff.size = var, small = FALSE, data = corrdat) N <- obj$M k <- obj$N expect_equal(as.numeric(vcovCR(obj, type = "CR0")), as.numeric(obj$VR.r)) expect_identical(as.numeric(clubSandwich:::coef_CS.robu(obj)), as.numeric(obj$b.r)) expect_identical(length(clubSandwich:::residuals_CS.robu(obj)), N) expect_identical(dim(clubSandwich:::model_matrix.robu(obj)), c(N, 1L)) expect_identical(dim(clubSandwich:::bread.robu(obj)), c(1L, 1L)) V_list <- clubSandwich:::targetVariance.robu(obj, cluster = obj$study_orig_id) expect_identical(as.integer(sapply(V_list, nrow)), obj$k) W_list <- clubSandwich:::weightMatrix.robu(obj, cluster = obj$study_orig_id) expect_identical(as.integer(sapply(W_list, nrow)), obj$k) }) corr_large <- robu(effectsize ~ males + college + binge, data = corrdat, modelweights = "CORR", studynum = studyid, var.eff.size = var, small = FALSE) test_that("CR0 z-tests agree with robumeta for correlated effects", { p <- length(coef_CS(corr_large)) N <- corr_large$N robu_CR0 <- vcovCR(corr_large, type = "CR0") ztests <- coef_test(corr_large, vcov = robu_CR0 * N / (N - p), test = "z") expect_equivalent(corr_large$VR.r, as.matrix(robu_CR0)) expect_equivalent(corr_large$reg_table$SE, ztests$SE) expect_equal(with(corr_large$reg_table, 2 * pnorm(abs(b.r / SE),lower.tail=FALSE)), ztests$p_z) }) corr_small <- robu(effectsize ~ males + college + binge, data = corrdat, modelweights = "CORR", studynum = studyid, var.eff.size = var) test_that("CR2 t-tests agree with robumeta for correlated effects", { robu_CR2 <- vcovCR(corr_small, type = "CR2") expect_true(check_CR(corr_small, vcov = robu_CR2)) # expect_true(check_CR(corr_small, vcov = "CR4")) CR2_ttests <- coef_test(corr_small, vcov = robu_CR2, test = "Satterthwaite") expect_equivalent(corr_small$VR.r, as.matrix(robu_CR2)) expect_equal(corr_small$dfs, CR2_ttests$df) expect_equal(corr_small$reg_table$prob, CR2_ttests$p_Satt) }) data(hierdat) hier_large <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, modelweights = "HIER", small = FALSE) test_that("CR0 z-tests agree with robumeta for hierarchical effects", { p <- length(coef_CS(hier_large)) N <- hier_large$N robu_CR0 <- vcovCR(hier_large, type = "CR0") ztests <- coef_test(hier_large, vcov = robu_CR0 * N / (N - p), test = "z") expect_equivalent(hier_large$VR.r, as.matrix(robu_CR0)) expect_equivalent(hier_large$reg_table$SE, ztests$SE) expect_equal(with(hier_large$reg_table, 2 * pnorm(abs(b.r / SE),lower.tail=FALSE)), ztests$p_z) }) hier_small <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, modelweights = "HIER") test_that("CR2 t-tests agree with robumeta for hierarchical effects", { robu_CR2 <- vcovCR(hier_small, type = "CR2") expect_true(check_CR(hier_small, vcov = robu_CR2)) # expect_true(check_CR(hier_small, vcov = "CR4")) CR2_ttests <- coef_test(hier_small, vcov = robu_CR2, test = "Satterthwaite") expect_equivalent(hier_small$VR.r, as.matrix(robu_CR2)) expect_equal(hier_small$dfs, CR2_ttests$df) expect_equal(hier_small$reg_table$prob, CR2_ttests$p_Satt) }) hierdat$user_wt <- 1 + rpois(nrow(hierdat), lambda = 1.2) user_large <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, userweights = user_wt, small = FALSE) test_that("CR0 z-tests agree with robumeta for user weighting", { p <- length(coef_CS(user_large)) N <- user_large$N robu_CR0 <- vcovCR(user_large, type = "CR0") ztests <- coef_test(user_large, vcov = robu_CR0 * N / (N - p), test = "z") expect_equivalent(user_large$VR.r, as.matrix(robu_CR0)) expect_equivalent(user_large$reg_table$SE, ztests$SE) expect_equal(with(user_large$reg_table, 2 * pnorm(abs(b.r / SE),lower.tail=FALSE)), ztests$p_z) }) user_small <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, userweights = user_wt) test_that("CR2 t-tests agree with robumeta for user weighting", { user_lm <- lm(effectsize ~ binge + followup + sreport + age, data = hierdat, weights = user_wt) expect_equivalent(coef_CS(user_lm), coef(user_lm)) robu_CR2 <- vcovCR(user_small, type = "CR2") expect_true(check_CR(user_small, vcov = robu_CR2)) expect_equivalent(user_small$VR.r, as.matrix(robu_CR2)) target <- user_small$data.full$avg.var.eff.size lm_CR2 <- vcovCR(user_lm, cluster = hierdat$studyid, type = "CR2", target = target) expect_equivalent(robu_CR2, lm_CR2) CR2_ttests <- coef_test(user_small, vcov = robu_CR2, test = "Satterthwaite", p_values = FALSE) # expect_equal(user_small$dfs, CR2_ttests$df) # expect_equal(user_small$reg_table$prob, CR2_ttests$p_Satt) lm_CR2_ttests <- coef_test(user_lm, vcov = "CR2", cluster = hierdat$studyid, target = user_small$data.full$avg.var.eff.size, test = "Satterthwaite", p_values = FALSE) compare_ttests(CR2_ttests, lm_CR2_ttests) }) test_that("bread works", { vcov_corr_large <- with(corr_large, chol2inv(chol(crossprod(Xreg, data.full$r.weights * Xreg)))) expect_equal(vcov_corr_large, bread(corr_large) / v_scale(corr_large)) vcov_corr_small <- with(corr_small, chol2inv(chol(crossprod(Xreg, data.full$r.weights * Xreg)))) expect_equal(vcov_corr_small, bread(corr_small) / v_scale(corr_small)) vcov_hier_large <- with(hier_large, chol2inv(chol(crossprod(Xreg, data.full$r.weights * Xreg)))) expect_equal(vcov_hier_large, bread(hier_large) / v_scale(hier_large)) vcov_hier_small <- with(hier_small, chol2inv(chol(crossprod(Xreg, data.full$r.weights * Xreg)))) expect_equal(vcov_hier_small, bread(hier_small) / v_scale(hier_small)) vcov_user_large <- with(user_large, chol2inv(chol(crossprod(Xreg, data.full$userweights * Xreg)))) expect_equal(vcov_user_large, bread(user_large) / v_scale(user_large)) vcov_user_small <- with(user_small, chol2inv(chol(crossprod(Xreg, data.full$userweights * Xreg)))) expect_equal(vcov_user_small, bread(user_small) / v_scale(user_small)) }) data(dropoutPrevention) test_that("dropoutPrevention tests replicate Tipton & Pustejovsky (2015) - full sample", { skip_on_cran() m3_hier <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + evaluator_independence + male_pct + white_pct + average_age + implementation_quality + program_site + duration + service_hrs, data = dropoutPrevention, studynum = studyID, var.eff.size = varLOR, modelweights = "HIER") m3_hier_CR2 <- vcovCR(m3_hier, cluster = dropoutPrevention$studyID, type = "CR2") expect_true(check_CR(m3_hier, vcov = m3_hier_CR2)) # expect_true(check_CR(m3_hier, vcov = "CR4")) CR2_ttests <- coef_test(m3_hier, vcov = m3_hier_CR2, test = "Satterthwaite") expect_equivalent(m3_hier$VR.r, as.matrix(m3_hier_CR2)) expect_equal(m3_hier$dfs, CR2_ttests$df) expect_equal(m3_hier$reg_table$prob, CR2_ttests$p_Satt) contrast_list <- list("Study design" = 2:3, "Outcome measure" = 7:9, "Evaluator independence" = 10:12, "Implmentation quality" = 16:17, "Program format" = 18:20) dropout_tests <- Wald_test(m3_hier, constraints = constrain_zero(contrast_list), vcov = m3_hier_CR2, test = c("Naive-F","HTZ")) Fstat_club <- sapply(dropout_tests, function(x) x$Fstat) attr(Fstat_club, "dimnames") <- NULL Fstat_paper <- matrix(c(0.23, 0.22, 0.91, 0.84, 3.11, 2.78, 14.15, 13.78, 3.85, 3.65), nrow = 2) expect_equivalent(Fstat_paper, round(Fstat_club, 2)) df_club <- sapply(dropout_tests, function(x) x$df_denom[2]) df_paper <- c(42.9, 21.5, 16.8, 36.9, 37.5) attr(df_club, "names") <- NULL expect_equivalent(df_paper, round(df_club, 1)) }) test_that("dropoutPrevention tests replicate Tipton & Pustejovsky (2015) - reduced sample", { skip_on_cran() dp_subset <- subset(dropoutPrevention, big_study==TRUE) m3_hier <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + evaluator_independence + male_pct + white_pct + average_age + implementation_quality + program_site + duration + service_hrs, data = dp_subset, studynum = studyID, var.eff.size = varLOR, modelweights = "HIER") m3_hier_CR2 <- vcovCR(m3_hier, cluster = dp_subset$studyID, type = "CR2") expect_true(check_CR(m3_hier, vcov = m3_hier_CR2)) CR2_ttests <- coef_test(m3_hier, vcov = m3_hier_CR2, test = "Satterthwaite") expect_equivalent(m3_hier$VR.r, as.matrix(m3_hier_CR2)) expect_equal(m3_hier$dfs, CR2_ttests$df) expect_equal(m3_hier$reg_table$prob, CR2_ttests$p_Satt) contrast_list <- list("Study design" = 2:3, "Outcome measure" = 7:9, "Evaluator independence" = 10:11, "Implmentation quality" = 15:16, "Program format" = 17:19) dropout_tests <- Wald_test(m3_hier, constraints = constrain_zero(contrast_list), vcov = "CR2", test = c("Naive-F","HTZ")) Fstat_club <- sapply(dropout_tests, function(x) x$Fstat) Fstat_paper <- matrix(c(3.19, 2.93, 1.05, 0.84, 0.32, 0.26, 4.02, 3.69, 1.19, 0.98), nrow = 2) attr(Fstat_club, "dimnames") <- NULL expect_equivalent(Fstat_paper, round(Fstat_club, 2)) df_club <- sapply(dropout_tests, function(x) x$df_denom[2]) df_paper <- c(11.0, 7.7, 4.6, 11.0, 9.1) attr(df_club, "names") <- NULL expect_equivalent(df_paper, round(df_club, 1)) }) CR_types <- paste0("CR",0:4) test_that("order doesn't matter", { skip_on_cran() dat_scramble <- corrdat[sample(nrow(corrdat)),] corr_scramble <- robu(effectsize ~ males + college + binge, data = dat_scramble, modelweights = "CORR", studynum = studyid, var.eff.size = var) CR_fit <- lapply(CR_types, function(x) vcovCR(corr_small, type = x)) CR_scramble <- lapply(CR_types, function(x) vcovCR(corr_scramble, type = x)) expect_equivalent(CR_fit, CR_scramble) test_fit <- lapply(CR_types, function(x) coef_test(corr_small, vcov = x, test = "All", p_values = FALSE)) test_scramble <- lapply(CR_types, function(x) coef_test(corr_scramble, vcov = x, test = "All", p_values = FALSE)) compare_ttests(test_fit, test_scramble) constraints <- combn(length(coef_CS(corr_small)), 2, simplify = FALSE) Wald_fit <- Wald_test(corr_small, constraints = constrain_zero(constraints), vcov = "CR2", test = "All") Wald_scramble <- Wald_test(corr_scramble, constraints = constrain_zero(constraints), vcov = "CR2", test = "All") compare_Waldtests(Wald_fit, Wald_scramble) }) test_that("clubSandwich works with dropped observations", { dat_miss <- hierdat dat_miss$binge[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 10))] <- NA dat_miss$followup[sample.int(nrow(hierdat), size = round(nrow(hierdat) / 20))] <- NA hier_drop <- robu(effectsize ~ binge + followup + sreport + age, data = dat_miss, studynum = studyid, var.eff.size = var, modelweights = "HIER") dat_complete <- subset(dat_miss, !is.na(binge) & !is.na(followup)) hier_complete <- robu(effectsize ~ binge + followup + sreport + age, data = dat_complete, studynum = studyid, var.eff.size = var, modelweights = "HIER") CR_drop <- lapply(CR_types, function(x) vcovCR(hier_drop, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(hier_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(hier_drop, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(hier_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete) }) test_that("vcovCR options work for CR2", { dp_subset <- subset(dropoutPrevention, big_study==TRUE) m3_hier <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + evaluator_independence + male_pct + white_pct + average_age + implementation_quality + program_site + duration + service_hrs, data = dp_subset, studynum = studyID, var.eff.size = varLOR, modelweights = "HIER") iv <- mean(m3_hier$data.full$r.weights) / m3_hier$data.full$r.weights CR2_iv <- vcovCR(m3_hier, type = "CR2") expect_equal(vcovCR(m3_hier, type = "CR2", inverse_var = TRUE), CR2_iv) expect_equal(vcovCR(m3_hier, type = "CR2", target = iv, inverse_var = TRUE), CR2_iv) CR2_not <- vcovCR(m3_hier, type = "CR2", inverse_var = FALSE) attr(CR2_iv, "inverse_var") <- FALSE attr(CR2_iv, "target") <- attr(CR2_not, "target") expect_equal(CR2_not, CR2_iv) expect_equal(vcovCR(m3_hier, type = "CR2", target = iv), CR2_not) expect_equal(vcovCR(m3_hier, type = "CR2", target = iv, inverse_var = FALSE), CR2_not) expect_false(identical(vcovCR(m3_hier, type = "CR2", target = m3_hier$data.full$var.eff.size), CR2_not)) }) test_that("Wald test problem.", { mod0 <- robu(formula = effectsize ~ 0 + factor(binge), data = hierdat, var.eff.size = var, studynum = studyid, modelweights = "HIER", small = TRUE) Wald0 <- Wald_test(mod0, constraints = constrain_equal(1:2), vcov = "CR2", test = "All") mod1 <- robu(formula = effectsize ~ binge, data = hierdat, var.eff.size = var, studynum = studyid, modelweights = "HIER", small = TRUE) Wald1 <- Wald_test(mod1, constraints = constrain_zero(2), vcov = "CR2", test = "All") compare_Waldtests(Wald0, Wald1) }) test_that("CR0 and CR2 agree with robumeta for user weighting with some zeros.", { hierdat$user_wt <- rpois(nrow(hierdat), lambda = 1.2) table(hierdat$user_wt) user_large <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, userweights = user_wt, small = FALSE) p <- length(coef_CS(user_large)) N <- user_large$N robu_CR0 <- vcovCR(user_large, type = "CR0") ztests <- coef_test(user_large, vcov = robu_CR0 * N / (N - p), test = "z") expect_equivalent(user_large$VR.r, as.matrix(robu_CR0)) expect_equivalent(user_large$reg_table$SE, ztests$SE) expect_equal(with(user_large$reg_table, 2 * pnorm(abs(b.r / SE),lower.tail=FALSE)), ztests$p_z) user_small <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, userweights = user_wt) user_lm <- lm(effectsize ~ binge + followup + sreport + age, data = hierdat, weights = user_wt) expect_equivalent(coef_CS(user_lm), coef(user_lm)) robu_CR2 <- vcovCR(user_small, type = "CR2") expect_true(check_CR(user_small, vcov = robu_CR2)) target <- user_small$data.full$avg.var.eff.size lm_CR2 <- vcovCR(user_lm, cluster = hierdat$studyid, type = "CR2", target = target) expect_equivalent(robu_CR2, lm_CR2) CR2_ttests <- coef_test(user_small, vcov = robu_CR2, test = "Satterthwaite", p_values = FALSE) lm_CR2_ttests <- coef_test(user_lm, vcov = "CR2", cluster = hierdat$studyid, target = user_small$data.full$avg.var.eff.size, test = "Satterthwaite", p_values = FALSE) compare_ttests(CR2_ttests, lm_CR2_ttests) }) test_that("clubSandwich works with weights of zero (kind of).", { hierdat$user_wt <- rpois(nrow(hierdat), lambda = 1.2) table(hierdat$user_wt) user_full <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, userweights = user_wt, small = FALSE) hierdat_sub <- subset(hierdat, user_wt > 0) user_sub <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat_sub, studynum = studyid, var.eff.size = var, userweights = user_wt) CR_full <- lapply(CR_types, function(x) vcovCR(user_full, type = x)) CR_sub <- lapply(CR_types, function(x) vcovCR(user_sub, type = x)) expect_equal(CR_full[c(1,2,4)], CR_sub[c(1,2,4)], check.attributes = FALSE) dat_miss <- hierdat miss_indicator <- sample.int(nrow(hierdat), size = round(nrow(hierdat) / 10)) dat_miss$binge[miss_indicator] <- NA with(dat_miss, table(user_wt, is.na(binge))) user_dropped <- robu(effectsize ~ binge + followup + sreport + age, data = dat_miss, studynum = studyid, var.eff.size = var, userweights = user_wt) dat_complete <- subset(dat_miss, !is.na(binge)) user_complete <- robu(effectsize ~ binge + followup + sreport + age, data = dat_complete, studynum = studyid, var.eff.size = var, userweights = user_wt) CR_drop <- lapply(CR_types, function(x) vcovCR(user_dropped, type = x)) CR_complete <- lapply(CR_types, function(x) vcovCR(user_complete, type = x)) expect_equal(CR_drop, CR_complete) test_drop <- lapply(CR_types, function(x) coef_test(user_dropped, vcov = x, test = "All", p_values = FALSE)) test_complete <- lapply(CR_types, function(x) coef_test(user_complete, vcov = x, test = "All", p_values = FALSE)) expect_equal(test_drop, test_complete, tolerance = 1e-6) }) clubSandwich/tests/testthat.R0000644000176200001440000000011014630154052015775 0ustar liggesuserslibrary(testthat) library(clubSandwich) test_check("clubSandwich") clubSandwich/MD50000644000176200001440000001334114635072452013202 0ustar liggesusers05a69e8db9c28e685d5d49340385dd39 *DESCRIPTION 554975df616f583f014757d96074070e *NAMESPACE 0a931242eecfe9f3981a7cb3802696c4 *NEWS.md a1c4db8cc7d1e4f2209e81d9049bccac *R/CR-adjustments.R 91d2efb468fdd6227c91cf2300b0044e *R/S3-methods.R 336badb483bb29b235c0112d4f05b303 *R/Wald_test.R 66d139ada642323ebc5bb736942341cc *R/clubSandwich.R a61e0154751ccc2b41b04ddc7a546255 *R/coef_test.R 5ed1e360322c1ebd14026cfd5d58ba52 *R/conf_int.R 6948376ba902bfeeea285e0a2a9a4ccb *R/data-documentation.R 4fdf3ff27ce61a3c49dc1c099ad9ceda *R/geeglm.R bb0d8db3acb8652cbbca2efb0cdfbf39 *R/get_arrays.R 3a3fe1e4f49c85dad4d8e8623414cda1 *R/glm.R 1bf4b04245bbc2b0c7a0beba36451b73 *R/gls.R fb5e175f375601fd969792b3cb8c129b *R/ivreg.R 6a425ebb1f8b54dcd4195ae7b4bf70c6 *R/lm.R 878431f8d11b487b99e73efc9aaa9432 *R/lme.R 236c086171e1e53b30e331b1a72547ad *R/lmer.R 2576290939fa9261d0a6990b3ee913cc *R/matrix-functions.R 40ddd50f0e90b7ad4744a977b9d3aba4 *R/mlm.R 2f592d749b8f6c46b46d72177db23e5e *R/plm.R 48df2b5edfd92a472cf85c8d9daee34b *R/rma-mv.R 3620d2c36c8d67a2613e629bdf7d06d4 *R/rma-uni.R 337e2a1285271f501d6af62af63b9ed5 *R/robu.R 51956f32395ffb30255e5d317481f5eb *R/utilities.R 24bc7c3f5a645905c53152bd3d0b8f61 *build/partial.rdb 2e8f89083c002b8928fa529d347032d2 *build/vignette.rds 8e550f05dda31b5c40d1817bae9a4363 *data/AchievementAwardsRCT.RData 34360e013336c721ad97d9c3658db4df *data/MortalityRates.RData 320879cf26bc98529a421a78626f4284 *data/SATcoaching.RData 6402f15efe8b3298b8dea6d9811a42ce *data/dropoutPrevention.RData e7b19faa3d196980280fffbfb31bb874 *inst/doc/Wald-tests-in-clubSandwich.R 57cb6087c04840ccb9e69e0499cd05c9 *inst/doc/Wald-tests-in-clubSandwich.Rmd bcbb25e3226ec720435782cca0f4ee95 *inst/doc/Wald-tests-in-clubSandwich.html 1d5c8d7281e46b7d0cd5f15867d8aa12 *inst/doc/meta-analysis-with-CRVE.R ebc446904160ac4add09b6ecf4e9a603 *inst/doc/meta-analysis-with-CRVE.Rmd 24ab4a56d479a26d0667617ecde8e6c1 *inst/doc/meta-analysis-with-CRVE.html 4696dee3df0c6762bb4bd97bede02146 *inst/doc/panel-data-CRVE.R 61021ce907fbc05526b3d76394c8bbd6 *inst/doc/panel-data-CRVE.Rmd 29eb636c069f1aff34fea70054bc82f4 *inst/doc/panel-data-CRVE.html f6eef2291de31f5b1f10fa04102ab609 *man/AchievementAwardsRCT.Rd 072c00478ebdbdedb9ea67c959c99fc8 *man/MortalityRates.Rd 7304421949562f2c392131aaafb1afe0 *man/SATcoaching.Rd 5a329d4113bd6aa0268ea1faf5e5b2f7 *man/Wald_test.Rd be4ab39d8903aa8546dc64347be52a86 *man/coef_test.Rd 74cd8e0310e3b85842235e2cdb93bbe7 *man/conf_int.Rd 0e44f362df4d2974c349722712471c39 *man/constraint_matrices.Rd 8dba42996033d40e13d8b0a192db1c34 *man/dropoutPrevention.Rd cd54b0805fd11acad870fcf8c7e52d83 *man/findCluster.rma.mv.Rd 9488482b7f440cb016856736cc96de7f *man/impute_covariance_matrix.Rd 078c9e1d19080608589145df80be285c *man/linear_contrast.Rd ca05b622a6e1ce60109f52ab6cb3c8a4 *man/pattern_covariance_matrix.Rd 198f468de2915ab1157789f00487cd23 *man/vcovCR.Rd 0090ec7a0cca196ee84e503d19e61829 *man/vcovCR.geeglm.Rd b89fc3af7660f17a83ebb90877f76ace *man/vcovCR.glm.Rd ef6e66f7286ce0bf4093e79580610575 *man/vcovCR.gls.Rd 641da2ab49f0fa699e13c90318508f6e *man/vcovCR.ivreg.Rd 56e10ed54e4b8cfedf2aad822c90a861 *man/vcovCR.lm.Rd 5a3090b35b0fe3d26d48b7be39194c33 *man/vcovCR.lme.Rd a6508917e5d0fa4e1916d6fe975bbfc6 *man/vcovCR.lmerMod.Rd a2c6d4e27c95695ff642889df556d0f2 *man/vcovCR.mlm.Rd bcbff1a0b5a8e3474c18113ddfa65cdd *man/vcovCR.plm.Rd 212df38f544a7e64efcb2920eee3d651 *man/vcovCR.rma.mv.Rd b3fb1637bee90baeb2755c88f5dd2895 *man/vcovCR.rma.uni.Rd 461b9e7729343401861bdfa1f9deebf3 *man/vcovCR.robu.Rd 77ee716352046c1d86deb383d1d5497a *tests/testthat.R 7b4feabc94745c032a3b14e1ced26d5c *tests/testthat/test_AER_ivreg.R d440fa580a7573a7cf84c5134a4f0580 *tests/testthat/test_Wald.R 496dade7481c704545b42e21d53040ff *tests/testthat/test_coef.R 57264754aa780ff807794104686098c3 *tests/testthat/test_conf_int.R f71801a1b6aeecd5804c13941bdac06e *tests/testthat/test_estfun.R 4b5c5922fe49498eac99dc0318cfad90 *tests/testthat/test_geeglm.R af8bd599de28704382d474ea15410ba3 *tests/testthat/test_glm_logit.R 3d0bf6a9b62443bb1a5acb574493443e *tests/testthat/test_gls.R 31083daff7e3904291808f2051f8b244 *tests/testthat/test_ignore_absorption.R d544ad56c93e1f10a7e00c09521f364a *tests/testthat/test_impute_covariance_matrix.R f31d0900fcf58534bc397aa43473f560 *tests/testthat/test_intercept_formulas.R 4f654c9b380ea95765496c051607a742 *tests/testthat/test_ivreg_ivreg.R 62a7e933b516b17b1dafc6001e5a1282 *tests/testthat/test_linear_contrast.R e1463e069b6705b8eb2aebff355d58fa *tests/testthat/test_lm.R 73f82f16b1cac2e57a23a362f1e7f41c *tests/testthat/test_lme_2level.R 5293a5130876b72252a38bfccf887d56 *tests/testthat/test_lme_3level.R 5b0e642d9b61a8dd1ccf0f5dd515d451 *tests/testthat/test_lme_MVML.R 14b742f504dc42d71f27be05d19b0b9f *tests/testthat/test_lmerMod.R 0032bb715b62139c7294f6bb88bd8df1 *tests/testthat/test_mlm.R ee132ac390f90a5c3aff36d651a24ea8 *tests/testthat/test_plm-ID-variables.R 588b5b0d192ac5155fb007744d367ee4 *tests/testthat/test_plm-first-differences.R 37add75e3bf443e3fb06038e6a014293 *tests/testthat/test_plm-fixed-effects.R 56da486857e8d4504e8aa8c1fe7937da *tests/testthat/test_plm-random-effects.R 4597e0d7dfbedc264c0ea336bc5229be *tests/testthat/test_plm-unbalanced-fixed-effects.R 6340d25105a42fbbccae93563efc2263 *tests/testthat/test_plm_overspecified_problem.R c36ac03370d8ed990681f61b4bdeb412 *tests/testthat/test_rma-ls.R a9508959eadcd19166f61c32f7feab60 *tests/testthat/test_rma-mv.R 3dd8d9da13c80eed49476f298ecae463 *tests/testthat/test_rma-uni.R 4cbe5aa4c7cefe867fe9906653244a36 *tests/testthat/test_robu.R 57cb6087c04840ccb9e69e0499cd05c9 *vignettes/Wald-tests-in-clubSandwich.Rmd 8a2356e12728ece3cfb80683505b6f97 *vignettes/apa.csl 64d69ef97a9a1853d40cb1ccc7e55257 *vignettes/bibliography.bib ebc446904160ac4add09b6ecf4e9a603 *vignettes/meta-analysis-with-CRVE.Rmd 61021ce907fbc05526b3d76394c8bbd6 *vignettes/panel-data-CRVE.Rmd clubSandwich/R/0000755000176200001440000000000014634640133013065 5ustar liggesusersclubSandwich/R/matrix-functions.R0000644000176200001440000000431514630154051016520 0ustar liggesusers #--------------------------------------------- # matrix manipulation functions #--------------------------------------------- sub_f <- function(x, fac, dim) { function(f) switch(dim, row = x[fac==f, ,drop=FALSE], col = x[ ,fac==f, drop=FALSE], both = x[fac==f, fac==f, drop=FALSE]) } matrix_list <- function(x, fac, dim) { if (is.vector(x)) { if (dim != "both") stop(paste0("Object must be a matrix in order to subset by ",dim,".")) x_list <- split(x, fac) lapply(x_list, function(x) diag(x, nrow = length(x))) } else { lapply(levels(fac), sub_f(x, fac, dim)) } } # turn block-diagonal into regular matrix unblock <- function(A, block = attr(A, "groups")) { if (is.null(block)) block <- factor(rep(names(A), times = sapply(A, function(x) dim(x)[1]))) n <- length(block) mat <- matrix(0, n, n) for (i in levels(block)) { index <- i == block mat[index,index] <- A[[i]] } return(mat) } matrix_power <- function(x, p, symmetric = TRUE, tol = -12) { eig <- eigen(x, symmetric = symmetric) val_p <- with(eig, ifelse(values > 10^tol, values^p, 0)) with(eig, vectors %*% (val_p * t(vectors))) } chol_psd <- function(x) with(eigen(x, symmetric=TRUE), sqrt(pmax(values,0)) * t(vectors)) add_submatrices <- function(indices, small_mat, big_mat) { levs <- levels(indices) for (i in 1:length(levs)) { ind <- levs[i] == indices big_mat[ind,ind] <- small_mat[[i]] + big_mat[ind,ind] } big_mat } add_bdiag <- function(small_mats, big_mats, crosswalk) { small_indices <- lapply(split(crosswalk[[1]], crosswalk[[2]]), droplevels) big_indices <- unique(crosswalk) big_indices <- big_indices[[2]][order(big_indices[[1]])] small_mats <- split(small_mats, big_indices) Map(add_submatrices, indices = small_indices, small_mat = small_mats, big_mat = big_mats) } nest_bdiag <- function(mats, crosswalk) { small_indices <- lapply(split(crosswalk[[1]], crosswalk[[2]]), droplevels) big_indices <- unique(crosswalk) big_indices <- big_indices[[2]][order(big_indices[[1]])] mat_groups <- split(mats, big_indices) Map(unblock, A = mat_groups) } clubSandwich/R/rma-uni.R0000644000176200001440000001252714630154051014562 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a rma.uni object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from a #' \code{\link[metafor]{rma.uni}} object. #' #' @param cluster Expression or vector indicating which observations #' belong to the same cluster. Required for \code{rma.uni} objects. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be diagonal #' with entries equal to the estimated marginal variance of the effect sizes. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @export #' #' @examples #' #' pkgs_available <- #' requireNamespace("metafor", quietly = TRUE) & #' requireNamespace("metadat", quietly = TRUE) #' #' if (pkgs_available) withAutoprint({ #' #' library(metafor) #' data(dat.assink2016, package = "metadat") #' #' mfor_fit <- rma.uni(yi ~ year + deltype, vi = vi, #' data = dat.assink2016) #' mfor_fit #' #' mfor_CR2 <- vcovCR(mfor_fit, type = "CR2", cluster = dat.assink2016$study) #' mfor_CR2 #' coef_test(mfor_fit, vcov = mfor_CR2, test = c("Satterthwaite", "saddlepoint")) #' Wald_test(mfor_fit, constraints = constrain_zero(2:4), vcov = mfor_CR2) #' #' }) #' vcovCR.rma.uni <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { if (missing(cluster)) stop("You must specify a clustering variable.") # if (length(cluster) != nrow(model_matrix(obj))) cluster <- droplevels(as.factor(cluster[obj$not.na])) # if (length(cluster) != nrow(model_matrix(obj))) stop("Clustering variable must have length equal to nrow(model_matrix(obj)).") if (missing(target)) { target <- NULL if (missing(inverse_var)) inverse_var <- is.null(obj$weights) & obj$weighted } else { if (missing(inverse_var)) inverse_var <- FALSE } vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } #----------------------------------------------- # residuals_CS() #----------------------------------------------- #' @export residuals_CS.rma <- function(obj) { res <- residuals(obj) not_na <- obj$not.na if (length(res) == length(not_na)) res <- res[not_na] if (!is.null(wts <- weights(obj)) && !all(pos_wts <- wts > 0)) { res <- res[pos_wts] } return(res) } #----------------------------------------------- # coefficients for location-scale model #----------------------------------------------- # coef_CS.default() used for rma.uni #' @export #' coef_CS.rma.ls <- function(obj) { metafor::coef.rma(obj)$beta } #----------------------------------------------- # coefficients for location-scale model #----------------------------------------------- # coef_CS.default() used for rma.uni #' @export #' coef_CS.rma.ls <- function(obj) { metafor::coef.rma(obj)$beta } #----------------------------------------------- # Model matrix for location-scale model #----------------------------------------------- # model_matrix.default() used for rma.uni #' @export #' model_matrix.rma.ls <- function(obj) { metafor::model.matrix.rma(obj)$location } # na.action #' @export na.action.rma <- function(object, ...) { if (all(object$not.na)) return(NULL) res <- which(!object$not.na) class(res) <- "omit" res } #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- #' @export targetVariance.rma.uni <- function(obj, cluster) { vi <- obj$vi if (obj$weighted && !is.null(wts <- obj$weights) && !all(pos_wts <- wts > 0)) { vi <- vi[pos_wts] } matrix_list(vi + obj$tau2, cluster, "both") } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.rma.uni <- function(obj, cluster) { if (obj$weighted) { if (is.null(obj$weights)) { wi <- 1 / (obj$vi + obj$tau2) } else { wi <- obj$weights wi <- wi[wi > 0] } } else { wi <- rep(1, obj$k) } w_scale <- mean(wi) wi <- wi / w_scale W_list <- matrix_list(wi, cluster, "both") attr(W_list, "w_scale") <- w_scale W_list } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.rma.uni <- function(x, ...) { X_mat <- model_matrix(x) if (x$weighted) { if (is.null(x$weights)) { wi <- 1 / (x$vi + x$tau2) } else { wi <- x$weights wi <- wi[wi > 0] } XWX <- crossprod(X_mat, wi * X_mat) } else { XWX <- crossprod(X_mat) } B <- chol2inv(chol(XWX)) * nobs(x) rownames(B) <- colnames(B) <- colnames(X_mat) B } #' @export v_scale.robu <- function(obj) { nobs(obj) } clubSandwich/R/plm.R0000644000176200001440000003215314630154051013777 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a plm object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from a \code{\link[plm]{plm}} #' object. #' #' @param cluster Optional character string, expression, or vector indicating #' which observations belong to the same cluster. For fixed-effect models that #' include individual effects or time effects (but not both), the cluster will #' be taken equal to the included fixed effects if not otherwise specified. #' Clustering on individuals can also be obtained by specifying the name of #' the individual index (e.g., \code{cluster = "state"}) or \code{cluster = #' "individual"}; clustering on time periods can be obtained by specifying the #' name of the time index (e.g., \code{cluster = "year"}) or \code{cluster = #' "time"}; if a group index is specified, clustering on groups (in which #' individuals are nested) can be obtained by specifying the name of the group #' index or \code{cluster = "group"}. For random-effects models, the cluster #' will be taken equal to the included random effect identifier if not #' otherwise specified. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. By default, the target is taken to be an identity #' matrix for fixed effect models or the estimated compound-symmetric #' covariance matrix for random effects models. #' @param ignore_FE Optional logical controlling whether fixed effects are #' ignored when calculating small-sample adjustments in models where fixed #' effects are estimated through absorption. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("plm", quietly = TRUE)) withAutoprint({ #' #' library(plm) #' # fixed effects #' data("Produc", package = "plm") #' plm_FE <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, #' data = Produc, index = c("state","year","region"), #' effect = "individual", model = "within") #' vcovCR(plm_FE, type="CR2") #' vcovCR(plm_FE, type = "CR2", cluster = Produc$region) # clustering on region #' #' # random effects #' plm_RE <- update(plm_FE, model = "random") #' vcovCR(plm_RE, type = "CR2") #' vcovCR(plm_RE, type = "CR2", cluster = Produc$region) # clustering on region #' #' # nested random effects #' plm_nested <- update(plm_FE, effect = "nested", model = "random") #' vcovCR(plm_nested, type = "CR2") # clustering on region #' }) #' #' pkgs_available <- requireNamespace("plm", quietly = TRUE) & requireNamespace("AER", quietly = TRUE) #' #' if (pkgs_available) withAutoprint({ #' # first differencing #' data(Fatalities, package = "AER") #' Fatalities <- within(Fatalities, { #' frate <- 10000 * fatal / pop #' drinkagec <- cut(drinkage, breaks = 18:22, include.lowest = TRUE, right = FALSE) #' drinkagec <- relevel(drinkagec, ref = 4) #' }) #' #' plm_FD <- plm(frate ~ beertax + drinkagec + miles + unemp + log(income), #' data = Fatalities, index = c("state", "year"), #' model = "fd") #' vcovHC(plm_FD, method="arellano", type = "sss", cluster = "group") #' vcovCR(plm_FD, type = "CR1S") #' vcovCR(plm_FD, type = "CR2") #' #' }) #' #' @export vcovCR.plm <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ignore_FE = FALSE, ...) { if (missing(cluster)) { cluster <- findCluster.plm(obj = obj) } else { cluster <- findCluster.plm(obj = obj, cluster = cluster) } if (missing(target)) target <- NULL if (missing(inverse_var)) inverse_var <- is.null(target) obj$na.action <- attr(obj$model, "na.action") vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form, ignore_FE = ignore_FE) } get_index_order <- function(obj) { envir <- environment(obj$formula) mf <- match.call(plm::plm, call = obj$call, envir = envir) dat <- eval(mf$data, envir) index_names <- eval(mf$index) if (inherits(dat, "pdata.frame") | is.numeric(index_names)) { indices <- plm::index(obj) } else { if (is.null(index_names)) index_names <- names(dat)[1:2] indices <- as.list(dat[index_names]) } if (length(indices) == 3) indices <- indices[c(3,1:2)] do.call(order, args = indices) } findCluster.plm <- function(obj, cluster) { index <- attr(model.frame(obj),"index") effect <- obj$args$effect if (obj$args$model=="random" & effect=="twoways") stop("Variance matrix is not block diagonal. clubSandwich methods are not available for such models.") if (missing(cluster)) { # Infer missing clustering variable if (effect=="twoways") stop("You must specify a clustering variable when effect = 'twoways'.") cluster <- switch(obj$args$effect, individual = index[[1]], time = index[[2]], nested = index[[3]]) } else if ((length(cluster)==1) & is.character(cluster)) { # Translate clustering variable keywords allowed_clusters <- switch(effect, individual = c("individual","group"), time = "time", twoways = "none", nested = "group") if (cluster %in% c("individual","time","group")) { # Check for nesting of random effects inside clusters if (obj$args$model == "random" & !cluster %in% allowed_clusters) { err_msg <- paste0("For a random effects model, cluster = '", cluster, "' is not allowed when effect = '", effect, "'.") stop(err_msg) } cluster <- switch(cluster, individual = index[[1]], time = index[[2]], group = index[[3]]) } else if (cluster %in% names(index)) { cluster_ID <- c("individual","time","group")[1:length(index)][cluster == names(index)] # Check for nesting of random effects inside clusters if (obj$args$model == "random" & !cluster_ID %in% allowed_clusters) { err_msg <- paste0("For a random effects model, cluster = '", cluster, "' is not allowed when effect = '", effect, "'.") stop(err_msg) } cluster <- index[[cluster]] } else { err_msg <- paste0("Clustering variable could not be inferred. Please check the argument cluster = '", cluster, "'.") stop(err_msg) } } else { # Sort user-specified clustering variable sort_order <- get_index_order(obj) cluster <- cluster[sort_order] } # Check for nesting of random effects inside clusters if (obj$args$model == "random") { RE_index <- switch(effect, individual = index[[1]], time = index[[2]], nested = index[[3]]) if(!check_nested(RE_index, cluster)) stop("Random effects are not nested within clustering variable. clubSandwich methods are not available for such models.") } if (obj$args$model=="fd") { cluster <- cluster[index[[2]] != levels(index[[2]])[1]] } cluster } #----------------------------------------------- # Model matrix #----------------------------------------------- #' @export model_matrix.plm <- function(obj) { if (obj$args$model=="random") { model.matrix(Formula::as.Formula(formula(obj)), model.frame(obj)) } else { cstcovar.rm <- switch(obj$args$model, within = "all", fd = "covariates", pooling = "none", between = "none") model.matrix(obj, model = obj$args$model, effect = obj$args$effect, cstcovar.rm = cstcovar.rm) } } #---------------------------------------------- # Augmented model matrix #---------------------------------------------- #' @export augmented_model_matrix.plm <- function(obj, cluster, inverse_var, ignore_FE) { index <- attr(model.frame(obj),"index") individual <- droplevels(as.factor(index[[1]])) time <- droplevels(as.factor(index[[2]])) effect <- obj$args$effect if (ignore_FE) { S <- NULL } else if (obj$args$model=="within") { if (effect=="individual") { if (inverse_var & identical(individual, cluster)) { S <- NULL } else { S <- model.matrix(~ 0 + individual) } } else if (effect=="time") { if (inverse_var & identical(time, cluster)) { S <- NULL } else { S <- model.matrix(~ 0 + time) } } else if (effect=="twoways") { if (inverse_var & identical(individual, cluster)) { S <- residuals(lm.fit(model.matrix(~ 0 + individual), model.matrix(~ 0 + time)[,-1])) } else if (inverse_var & identical(time, cluster)) { S <- residuals(lm.fit(model.matrix(~ 0 + time), model.matrix(~ 0 + individual)[,-1])) } else { S <- model.matrix(~ 0 + individual + time) } } } else { S <- NULL } return(S) } #------------------------------------- # unadjusted residuals #------------------------------------- #' @export residuals_CS.plm <- function(obj) { if (obj$args$model=="random") { y <- plm::pmodel.response(formula(obj), model.frame(obj), model = "pooling") nm <- names(y) y <- as.numeric(y) names(y) <- nm Xb <- as.numeric(model_matrix(obj) %*% coef(obj)) y - Xb } else { residuals(obj) } } #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- block_mat <- function(nj, r) { Vj <- matrix(r, nj, nj) diag(Vj) <- 1 + r Vj } #' @export targetVariance.plm <- function(obj, cluster) { if (obj$args$model=="random") { index <- attr(model.frame(obj),"index") r <- obj$ercomp$sigma2[[2]] / obj$ercomp$sigma2[[1]] if (obj$args$effect=="nested") { r_grp <- obj$ercomp$sigma2[[3]] / obj$ercomp$sigma2[[1]] grp_mat <- lapply(table(index[[3]]), function(x) matrix(r_grp, nrow = x, ncol = x)) ind_mat <- lapply(table(index[[1]]), block_mat, r = r) RE_index <- index[[3]] target_mat <- add_bdiag(ind_mat, grp_mat, crosswalk = index[c(1,3)]) } else { RE_index <- switch(obj$args$effect, individual = index[[1]], time = index[[2]]) target_mat <- lapply(table(RE_index), block_mat, r = r) } nest_bdiag(target_mat, crosswalk = data.frame(RE_index, cluster)) } else { matrix_list(rep(1, nobs(obj)), cluster, "both") } } #------------------------------------- # Get weighting matrix #------------------------------------- inverse_block_mat <- function(nj, r) { theta <- r / (1 + r * nj) Wj <- matrix(-theta, nj, nj) diag(Wj) <- 1 - theta Wj } inverse_nested_block_mat <- function(nj, r1, r2) { V_inv <- lapply(nj, inverse_block_mat, r = r1) const <- 1 / sqrt(1 / r2 + sum(nj / (1 + r1 * nj))) vec <- const * rep(1 / (1 + nj * r1), nj) indices <- factor(names(vec), levels = names(nj)) add_submatrices(indices, small_mat = V_inv, big_mat = -tcrossprod(vec)) } #' @export weightMatrix.plm <- function(obj, cluster) { if (obj$args$model=="random") { index <- attr(model.frame(obj),"index") r <- obj$ercomp$sigma2[[2]] / obj$ercomp$sigma2[[1]] if (obj$args$effect=="nested") { r_grp <- obj$ercomp$sigma2[[3]] / obj$ercomp$sigma2[[1]] njs <- tapply(index[[1]], index[[3]], function(x) table(droplevels(x))) RE_index <- index[[3]] target_mat <- lapply(njs, inverse_nested_block_mat, r1 = r, r2 = r_grp) } else { RE_index <- switch(obj$args$effect, individual = index[[1]], time = index[[2]]) target_mat <- lapply(table(RE_index), inverse_block_mat, r = r) } nest_bdiag(target_mat, crosswalk = data.frame(RE_index, cluster)) } else { matrix_list(rep(1, nobs(obj)), cluster, "both") } } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.plm <- function(x, ...) { v_scale(x) * vcov(x) / with(x, sum(residuals^2) / df.residual) } #' @export v_scale.plm <- function(obj) { max(sapply(attr(obj$model, "index"), nlevels)) } clubSandwich/R/clubSandwich.R0000644000176200001440000003107514630154051015617 0ustar liggesusers#---------------------------------------------- # user-facing vcovCR function #---------------------------------------------- #' Cluster-robust variance-covariance matrix #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates. #' #' @param obj Fitted model for which to calculate the variance-covariance matrix #' @param cluster Expression or vector indicating which observations belong to #' the same cluster. For some classes, the cluster will be detected #' automatically if not specified. #' @param type Character string specifying which small-sample adjustment should #' be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, #' \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of #' \code{\link{vcovCR}} for further information. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If a vector, the target matrix is assumed to be #' diagonal. If not specified, \code{vcovCR} will attempt to infer a value. #' @param inverse_var Optional logical indicating whether the weights used in #' fitting the model are inverse-variance. If not specified, \code{vcovCR} #' will attempt to infer a value. #' @param form Controls the form of the returned matrix. The default #' \code{"sandwich"} will return the sandwich variance-covariance matrix. #' Alternately, setting \code{form = "meat"} will return only the meat of the #' sandwich and setting \code{form = B}, where \code{B} is a matrix of #' appropriate dimension, will return the sandwich variance-covariance matrix #' calculated using \code{B} as the bread. \code{form = "estfun"} will return the #' (appropriately scaled) estimating function, the transposed crossproduct of #' which is equal to the sandwich variance-covariance matrix. #' @param ... Additional arguments available for some classes of objects. #' #' @description This is a generic function, with specific methods defined for #' \code{\link[stats]{lm}}, \code{\link[plm]{plm}}, \code{\link[stats]{glm}}, #' \code{\link[nlme]{gls}}, \code{\link[nlme]{lme}}, #' \code{\link[robumeta]{robu}}, \code{\link[metafor]{rma.uni}}, and #' \code{\link[metafor]{rma.mv}} objects. #' #' @details Several different small sample corrections are available, which run #' parallel with the "HC" corrections for heteroskedasticity-consistent #' variance estimators, as implemented in \code{\link[sandwich]{vcovHC}}. The #' "CR2" adjustment is recommended (Pustejovsky & Tipton, 2017; Imbens & #' Kolesar, 2016). See Pustejovsky and Tipton (2017) and Cameron and Miller #' (2015) for further technical details. Available options include: \describe{ #' \item{"CR0"}{is the original form of the sandwich estimator (Liang & Zeger, #' 1986), which does not make any small-sample correction.} #' \item{"CR1"}{multiplies CR0 by \code{m / (m - 1)}, where \code{m} is the #' number of clusters.} #' \item{"CR1p"}{multiplies CR0 by \code{m / (m - p)}, where \code{m} is the #' number of clusters and \code{p} is the number of covariates.} #' \item{"CR1S"}{multiplies CR0 by \code{(m (N-1)) / [(m - #' 1)(N - p)]}, where \code{m} is the number of clusters, \code{N} is the #' total number of observations, and \code{p} is the number of covariates. #' Some Stata commands use this correction by default.} #' \item{"CR2"}{is the #' "bias-reduced linearization" adjustment proposed by Bell and McCaffrey #' (2002) and further developed in Pustejovsky and Tipton (2017). The #' adjustment is chosen so that the variance-covariance estimator is exactly #' unbiased under a user-specified working model.} #' \item{"CR3"}{approximates the leave-one-cluster-out jackknife variance estimator (Bell & McCaffrey, #' 2002).} } #' #' @references Bell, R. M., & McCaffrey, D. F. (2002). Bias reduction in #' standard errors for linear regression with multi-stage samples. Survey #' Methodology, 28(2), 169-181. #' #' Cameron, A. C., & Miller, D. L. (2015). A Practitioner's Guide to #' Cluster-Robust Inference. \emph{Journal of Human Resources, 50}(2), 317-372. #' \doi{10.3368/jhr.50.2.317} #' #' Imbens, G. W., & Kolesar, M. (2016). Robust standard errors in small samples: #' Some practical advice. \emph{Review of Economics and Statistics, 98}(4), #' 701-712. \doi{10.1162/rest_a_00552} #' #' Liang, K.-Y., & Zeger, S. L. (1986). Longitudinal data analysis using #' generalized linear models. \emph{Biometrika, 73}(1), 13-22. #' \doi{10.1093/biomet/73.1.13} #' #' Pustejovsky, J. E. & Tipton, E. (2018). Small sample methods for #' cluster-robust variance estimation and hypothesis testing in fixed effects #' models. \emph{Journal of Business and Economic Statistics, 36}(4), 672-683. #' \doi{10.1080/07350015.2016.1247004} #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. The matrix has several attributes: #' \describe{ \item{type}{indicates which small-sample adjustment was used} #' \item{cluster}{contains the factor vector that defines independent #' clusters} \item{bread}{contains the bread matrix} \item{v_scale}{constant #' used in scaling the sandwich estimator} \item{est_mats}{contains a list of #' estimating matrices used to calculate the sandwich estimator} #' \item{adjustments}{contains a list of adjustment matrices used to calculate #' the sandwich estimator} \item{target}{contains the working #' variance-covariance model used to calculate the adjustment matrices. This #' is needed for calculating small-sample corrections for Wald tests.} } #' #' @seealso \code{\link{vcovCR.lm}}, \code{\link{vcovCR.plm}}, #' \code{\link{vcovCR.glm}}, \code{\link{vcovCR.gls}}, #' \code{\link{vcovCR.lme}}, \code{\link{vcovCR.lmerMod}}, \code{\link{vcovCR.robu}}, #' \code{\link{vcovCR.rma.uni}}, \code{\link{vcovCR.rma.mv}} #' #' @examples #' #' # simulate design with cluster-dependence #' m <- 8 #' cluster <- factor(rep(LETTERS[1:m], 3 + rpois(m, 5))) #' n <- length(cluster) #' X <- matrix(rnorm(3 * n), n, 3) #' nu <- rnorm(m)[cluster] #' e <- rnorm(n) #' y <- X %*% c(.4, .3, -.3) + nu + e #' dat <- data.frame(y, X, cluster, row = 1:n) #' #' # fit linear model #' lm_fit <- lm(y ~ X1 + X2 + X3, data = dat) #' vcov(lm_fit) #' #' # cluster-robust variance estimator with CR2 small-sample correction #' vcovCR(lm_fit, cluster = dat$cluster, type = "CR2") #' #' # compare small-sample adjustments #' CR_types <- paste0("CR",c("0","1","1S","2","3")) #' sapply(CR_types, function(type) #' sqrt(diag(vcovCR(lm_fit, cluster = dat$cluster, type = type)))) #' #' @export #' @import stats vcovCR <- function(obj, cluster, type, target, inverse_var, form, ...) UseMethod("vcovCR") #' Cluster-robust variance-covariance matrix #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates. #' #' @rdname vcovCR #' @export vcovCR.default <- function(obj, cluster, type, target = NULL, inverse_var = FALSE, form = "sandwich", ...) vcov_CR(obj, cluster, type, target, inverse_var, form) #--------------------------------------------- # Cluster-robust variance estimator #--------------------------------------------- handle_vectors <- function(x, obj) { # Handle omitted observations due to missing outcome or predictors if (inherits(na.action(obj), "omit")) { x <- x[-na.action(obj)] } # Handle observations omitted due to weights of zero if (!is.null(wts <- weights(obj))) { pos_wts <- wts > 0 if (!all(pos_wts)) x <- x[pos_wts] } return(x) } adjust_est_mats <- function(type, est_mats, adjustments) { switch(type, CR0 = est_mats, CR1 = lapply(est_mats, function(e) e * adjustments), CR1p = lapply(est_mats, function(e) e * adjustments), CR1S = lapply(est_mats, function(e) e * adjustments), CR2 = Map(function(e, a) e %*% a, e = est_mats, a = adjustments), CR3 = Map(function(e, a) e %*% a, e = est_mats, a = adjustments), CR4 = Map(function(e, a) a %*% e, e = est_mats, a = adjustments)) } # uses methods: # residuals_CS(), # model_matrix(), # weightMatrix(), # targetVariance(), # bread(), # v_scale() vcov_CR <- function(obj, cluster, type, target = NULL, inverse_var = FALSE, form = "sandwich", ignore_FE = FALSE) { cluster <- droplevels(as.factor(cluster)) alias <- is.na(coef_CS(obj)) X <- model_matrix(obj) if (any(alias)) { X <- X[, !alias, drop = FALSE] } p <- NCOL(X) N <- NROW(X) cluster_length <- length(cluster) if (cluster_length != N) { cluster <- droplevels(handle_vectors(cluster, obj)) if (length(cluster) != N) { stop("Clustering variable must have length equal to the number of rows in the data used to fit obj.") } } if (any(is.na(cluster))) stop("Clustering variable cannot have missing values.") J <- nlevels(cluster) if (J < 2) stop("Cluster-robust variance estimation will not work when the data only includes a single cluster.") X_list <- matrix_list(X, cluster, "row") W_list <- weightMatrix(obj, cluster) XW_list <- Map(function(x, w) as.matrix(t(x) %*% w), x = X_list, w = W_list) if (is.null(target)) { if (inverse_var) { Theta_list <- lapply(W_list, function(w) chol2inv(chol(w))) } else { Theta_list <- targetVariance(obj, cluster) } } else { if (!is.list(target)) { if (length(target) != N) { target <- handle_vectors(target, obj) } Theta_list <- matrix_list(target, cluster, "both") } else { Theta_list <- target } } if (type %in% c("CR2","CR4")) { S <- augmented_model_matrix(obj, cluster, inverse_var, ignore_FE) if (is.null(S)) { rm(S) U_list <- X_list UW_list <- XW_list } else { U <- cbind(X, S) rm(S) U_list <- matrix_list(U, cluster, "row") UW_list <- Map(function(u, w) as.matrix(t(u) %*% w), u = U_list, w = W_list) } UWU_list <- Map(function(uw, u) uw %*% u, uw = UW_list, u = U_list) M_U <- matrix_power(Reduce("+",UWU_list), p = -1) } adjustments <- do.call(type, args = mget(names(formals(type)))) E_list <- adjust_est_mats(type = type, est_mats = XW_list, adjustments = adjustments) resid <- residuals_CS(obj) res_list <- split(resid, cluster) components <- do.call(cbind, Map(function(e, r) e %*% r, e = E_list, r = res_list)) v_scale <- v_scale(obj) w_scale <- attr(W_list, "w_scale") if (is.null(w_scale)) w_scale <- 1L if (form == "estfun") { bread <- sandwich::bread(obj) estfun <- bread %*% components return(estfun * (w_scale / v_scale)) } meat <- tcrossprod(components) * w_scale^2 / v_scale if (form == "sandwich") { bread <- sandwich::bread(obj) } else if (form == "meat") { bread <- NULL } else if (is.matrix(form)) { bread <- form form <- "sandwich" } vcov <- switch(form, sandwich = bread %*% meat %*% bread / v_scale, meat = meat) rownames(vcov) <- colnames(vcov) <- colnames(X) attr(vcov, "type") <- type attr(vcov, "cluster") <- cluster attr(vcov, "bread") <- bread attr(vcov, "v_scale") <- v_scale attr(vcov, "est_mats") <- XW_list attr(vcov, "adjustments") <- adjustments attr(vcov, "target") <- Theta_list attr(vcov, "inverse_var") <- inverse_var attr(vcov, "ignore_FE") <- ignore_FE class(vcov) <- c("vcovCR","clubSandwich") return(vcov) } #--------------------------------------------- # as.matrix method for vcovCR #--------------------------------------------- #' @export as.matrix.clubSandwich <- function(x, ...) { attr(x, "type") <- NULL attr(x, "cluster") <- NULL attr(x, "bread") <- NULL attr(x, "v_scale") <- NULL attr(x, "est_mats") <- NULL attr(x, "adjustments") <- NULL attr(x, "target") <- NULL attr(x, "inverse_var") <- NULL attr(x, "ignore_FE") <- NULL class(x) <- "matrix" x } #--------------------------------------------- # print method for vcovCR #--------------------------------------------- #' @export print.clubSandwich <- function(x, ...) { print(as.matrix(x)) } clubSandwich/R/gls.R0000644000176200001440000001253714630154051014000 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a gls object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from a \code{\link[nlme]{gls}} object. #' #' @param cluster Optional expression or vector indicating which observations #' belong to the same cluster. If not specified, will be set to #' \code{getGroups(obj)}. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be the #' estimated variance-covariance structure of the \code{gls} object. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("nlme", quietly = TRUE)) { #' #' library(nlme) #' data(Ovary, package = "nlme") #' Ovary$time_int <- 1:nrow(Ovary) #' lm_AR1 <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = Ovary, #' correlation = corAR1(form = ~ time_int | Mare)) #' vcovCR(lm_AR1, type = "CR2") #' #' } #' #' @export vcovCR.gls <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { if (missing(cluster)) cluster <- nlme::getGroups(obj) if (missing(target)) target <- NULL if (missing(inverse_var) ) inverse_var <- is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # residuals_CS() # coef() # nobs() #------------------------------------- # model_matrix() #------------------------------------- get_data <- function (object) { if ("data" %in% names(object)) { data <- object$data } else { dat_call <- object$call$data envir_names <- sys.frames() data <- simpleError("start") i <- 1L while (inherits(data, "simpleError") & i <= length(envir_names)) { data <- tryCatch(eval(dat_call, envir = envir_names[[i]]), error = function(e) e) i <- i + 1L } } if (inherits(data, "simpleError")) return(NULL) naAct <- object[["na.action"]] if (!is.null(naAct)) { data <- if (inherits(naAct, "omit")) { data[-naAct, ] } else if (inherits(naAct, "exclude")) { data } else eval(object$call$na.action)(data) } subset <- object$call$subset if (!is.null(subset)) { subset <- eval(asOneSidedFormula(subset)[[2]], data) data <- data[subset, ] } data } #' @export model_matrix.gls <- function(obj) { dat <- get_data(obj) model.matrix(formula(obj), data = dat) } #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- #' @export targetVariance.gls <- function(obj, cluster = nlme::getGroups(obj)) { groups <- nlme::getGroups(obj) if (is.null(groups)) groups <- cluster if (is.null(obj$modelStruct$corStruct)) { if (is.null(obj$modelStruct$varStruct)) { V_list <- matrix_list(rep(1, length(cluster)), cluster, "both") } else { wts <- nlme::varWeights(obj$modelStruct$varStruct) V_list <- matrix_list(1 / wts^2, cluster, "both") } } else { R_list <- nlme::corMatrix(obj$modelStruct$corStruct) if (is.null(obj$modelStruct$varStruct)) { V_list <- R_list } else { sd_vec <- 1 / nlme::varWeights(obj$modelStruct$varStruct)[order(order(groups))] sd_list <- split(sd_vec, groups) V_list <- Map(function(R, s) tcrossprod(s) * R, R = R_list, s = sd_list) } } # check if clustering level is higher than highest level of random effects tb_groups <- table(groups) tb_cluster <- table(cluster) if (length(tb_groups) < length(tb_cluster) | any(as.vector(tb_groups) != rep(as.vector(tb_cluster), length.out = length(tb_groups))) | any(names(tb_groups) != rep(names(tb_cluster), length.out = length(tb_groups)))) { # check that random effects are nested within clusters tb_cross <- table(groups, cluster) nested <- apply(tb_cross, 1, function(x) sum(x > 0) == 1) if (!all(nested)) stop("Random effects are not nested within clustering variable.") # expand target_list to level of clustering crosswalk <- data.frame(groups, cluster) V_list <- add_bdiag(small_mats = V_list, big_mats = matrix_list(rep(0, length(cluster)), cluster, dim = "both"), crosswalk = crosswalk) } V_list } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.gls <- function(obj, cluster = nlme::getGroups(obj)) { V_list <- targetVariance(obj, cluster) lapply(V_list, function(v) chol2inv(chol(v))) } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.gls <- function(x, ...) { vcov(x) * nobs(x) / x$sigma^2 } # v_scale() is defaultclubSandwich/R/CR-adjustments.R0000644000176200001440000000605014630154051016047 0ustar liggesusers#--------------------------------------------- # Auxilliary functions for CR* functions #--------------------------------------------- IH_jj_list <- function(M, X_list, XW_list) { Map(function(x, xw) diag(nrow = nrow(x)) - x %*% M %*% xw, x = X_list, xw = XW_list) } #--------------------------------------------- # Estimating function adjustments #--------------------------------------------- CR0 <- function(J) NULL CR1 <- function(J) sqrt(J / (J - 1)) CR1p <- function(J, p) sqrt(J / (J - p)) CR1S <- function(J, N, p) sqrt(J * (N - 1) / ((J - 1) * (N - p))) CR2 <- function(M_U, U_list, UW_list, Theta_list, inverse_var = FALSE) { Theta_chol <- lapply(Theta_list, chol) if (inverse_var) { IH_jj <- IH_jj_list(M_U, U_list, UW_list) G_list <- Map(function(a,b,ih) as.matrix(a %*% ih %*% b %*% t(a)), a = Theta_chol, b = Theta_list, ih = IH_jj) } else { H_jj <- Map(function(u, uw) u %*% M_U %*% uw, u = U_list, uw = UW_list) uwTwu <- Map(function(uw, th) uw %*% th %*% t(uw), uw = UW_list, th = Theta_list) MUWTWUM <- M_U %*% Reduce("+", uwTwu) %*% M_U G_list <- Map(function(thet, h, u, v) as.matrix(v %*% (thet - h %*% thet - thet %*% t(h) + u %*% MUWTWUM %*% t(u)) %*% t(v)), thet = Theta_list, h = H_jj, u = U_list, v = Theta_chol) } Map(function(v, g) as.matrix(t(v) %*% matrix_power(g, -1/2) %*% v), v = Theta_chol, g = G_list) } CR3 <- function(X_list, XW_list) { XWX_list <- Map(function(xw, x) xw %*% x, xw = XW_list, x = X_list) M <- chol2inv(chol(Reduce("+", XWX_list))) IH_jj <- IH_jj_list(M, X_list, XW_list) lapply(IH_jj, solve) } CR4 <- function(M_U, U_list, UW_list, X_list, XW_list, Theta_list, inverse_var = FALSE) { if (inverse_var) { F_list <- Map(function(xw, x) xw %*% x, xw = XW_list, x = X_list) UWX_list <- Map(function(uw, x) uw %*% x, uw = UW_list, x = X_list) F_chol <- lapply(F_list, chol_psd) G_list <- Map(function(fc, fm, uwx) fc %*% (fm - t(uwx) %*% M_U %*% uwx) %*% t(fc), fc = F_chol, fm = F_list, uwx = UWX_list) } else { F_list <- Map(function(xw, theta) xw %*% theta %*% t(xw), xw = XW_list, theta = Theta_list) F_chol <- lapply(F_list, chol_psd) UWX_list <- Map(function(uw, x) uw %*% x, uw = UW_list, x = X_list) UWTWX_list <- Map(function(uw, xw, theta) uw %*% theta %*% t(xw), uw = UW_list, xw = XW_list, theta = Theta_list) UWTWU_list <- Map(function(uw, theta) uw %*% theta %*% t(uw), uw = UW_list, theta = Theta_list) MUWTWUM <- M_U %*% Reduce("+", UWTWU_list) %*% M_U G_list <- Map(function(fc, fm, uwx, uwtwx) as.matrix(fc %*% (fm - t(uwx) %*% M_U %*% uwtwx - t(uwtwx) %*% M_U %*% uwx + t(uwx) %*% MUWTWUM %*% uwx) %*% t(fc)), fc = F_chol, fm = F_list, uwx = UWX_list, uwtwx = UWTWX_list) } Map(function(fc, g) as.matrix(t(fc) %*% matrix_power(g, -1/2) %*% fc), fc = F_chol, g = G_list) } clubSandwich/R/robu.R0000644000176200001440000001167114630154051014160 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a robu object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from a #' \code{\link[robumeta]{robu}} object. #' #' @param cluster Optional expression or vector indicating which observations #' belong to the same cluster. If not specified, will be set to the #' \code{studynum} used in fitting the \code{\link[robumeta]{robu}} object. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be the #' inverse of the estimated weights used in fitting the #' \code{\link[robumeta]{robu}} object. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @export #' #' @examples #' #' if (requireNamespace("robumeta", quietly = TRUE)) withAutoprint({ #' library(robumeta) #' data(hierdat) #' #' robu_fit <- robu(effectsize ~ binge + followup + sreport + age, #' data = hierdat, studynum = studyid, #' var.eff.size = var, modelweights = "HIER") #' robu_fit #' #' robu_CR2 <- vcovCR(robu_fit, type = "CR2") #' robu_CR2 #' coef_test(robu_fit, vcov = robu_CR2, test = c("Satterthwaite", "saddlepoint")) #' #' Wald_test(robu_fit, constraints = constrain_zero(c(2,4)), vcov = robu_CR2) #' Wald_test(robu_fit, constraints = constrain_zero(2:5), vcov = robu_CR2) #' #' }) #' vcovCR.robu <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { if (missing(cluster)) cluster <- obj$study_orig_id if (missing(target)) target <- NULL if (missing(inverse_var)) inverse_var <- is.null(target) & (!obj$user_weighting) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } #----------------------------------------------- # coefficients #----------------------------------------------- #' @export coef_CS.robu <- function(obj) { beta <- as.vector(obj$b.r) labs <- obj$reg_table$labels if (is.factor(labs)) labs <- levels(labs)[labs] names(beta) <- labs beta } #----------------------------------------------- # residuals #----------------------------------------------- #' @export residuals_CS.robu <- function(obj) { ord <- order(order(obj$study_orig_id)) resid <- obj$data.full$e.r[ord] if (obj$user_weighting) { pos_wts <- obj$data.full$userweights[ord] > 0 if (!all(pos_wts)) resid <- resid[pos_wts] } return(resid) } #----------------------------------------------- # Model matrix #----------------------------------------------- #' @export model_matrix.robu <- function(obj) { ord <- order(order(obj$study_orig_id)) model_matrix <- obj$Xreg[ord,,drop=FALSE] if (obj$user_weighting) { pos_wts <- obj$data.full$userweights[ord] > 0 if (!all(pos_wts)) model_matrix <- model_matrix[pos_wts,,drop=FALSE] } return(model_matrix) } #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- #' @export targetVariance.robu <- function(obj, cluster) { ord <- order(order(obj$study_orig_id)) if (obj$user_weighting) { pos_wts <- obj$data.full$userweights[ord] > 0 V <- obj$data.full$avg.var.eff.size[ord][pos_wts] } else { V <- mean(obj$data.full$r.weights) / obj$data.full$r.weights[ord] } matrix_list(V, cluster, "both") } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weights.robu <- function(object, ...) { ord <- order(order(object$study_orig_id)) if (object$user_weighting) { object$data.full$userweights[ord] } else{ NULL } } #' @export weightMatrix.robu <- function(obj, cluster) { ord <- order(order(obj$study_orig_id)) if (obj$user_weighting) { W <- obj$data.full$userweights[ord] W <- W[W > 0] } else{ W <- obj$data.full$r.weights[ord] } w_scale <- mean(W) W <- W / w_scale W_list <- matrix_list(W, cluster, "both") attr(W_list, "w_scale") <- w_scale W_list } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.robu <- function(x, ...) { if (x$user_weighting) { W <- x$data.full$userweights } else{ W <- x$data.full$r.weights } x$N * chol2inv(chol(crossprod(x$Xreg, W * x$Xreg))) } #' @export v_scale.robu <- function(obj) { obj$N } clubSandwich/R/get_arrays.R0000644000176200001440000001460614630154051015352 0ustar liggesusers #-------------------------- # get G list and H array #-------------------------- get_GH <- function(obj, vcov) { cluster <- attr(vcov, "cluster") M <- attr(vcov, "bread") / attr(vcov, "v_scale") E_list <- adjust_est_mats(type = attr(vcov, "type"), est_mats = attr(vcov, "est_mats"), adjustments = attr(vcov, "adjustments")) target <- attr(vcov, "target") inverse_var <- attr(vcov, "inverse_var") ignore_FE <- attr(vcov, "ignore_FE") N <- length(cluster) J <- nlevels(cluster) X <- model_matrix(obj) alias <- is.na(coef_CS(obj)) if (any(alias)) X <- X[, !alias, drop = FALSE] p <- ncol(X) W_list <- weightMatrix(obj, cluster) w_scale <- attr(W_list, "w_scale") if (is.null(w_scale)) w_scale <- 1 S <- augmented_model_matrix(obj, cluster, inverse_var, ignore_FE) if (is.null(S)) { U_list <- matrix_list(X, cluster, "row") rm(X, S) u <- p UW_list <- Map(function(u, w) as.matrix(t(u) %*% w), u = U_list, w = W_list) M_U <- w_scale * M } else { U_list <- matrix_list(cbind(X, S), cluster, "row") rm(X, S) u <- ncol(U_list[[1]]) UW_list <- Map(function(u, w) as.matrix(t(u) %*% w), u = U_list, w = W_list) UWU_list <- Map(function(uw, u) uw %*% u, uw = UW_list, u = U_list) M_U <- chol2inv(chol(Reduce("+",UWU_list))) rm(UWU_list) } M_U_ct <- t(chol(M_U)) ME_list <- lapply(E_list, function(e) M %*% e) G_list <- Map(function(me, theta) me %*% t(chol(theta)), me = ME_list, theta = target) if (inverse_var) { H_array <- array(unlist(Map(function(me, u) me %*% u %*% M_U_ct, me = ME_list, u = U_list)), dim = c(p, u, J)) } else { H_array <- array(NA, dim = c(3, p, u, J)) MEU_list <- Map(function(me, u) me %*% u, me = ME_list, u = U_list) H_array[1,,,] <- unlist(lapply(MEU_list, function(meu) meu %*% M_U_ct)) TWU_list <- Map(function(t, w, u) t %*% w %*% u, t = target, w = W_list, u = U_list) MEF_list <- Map(function(me, twu) me %*% twu, me = ME_list, twu = TWU_list) H_array[2,,,] <- unlist(lapply(MEF_list, function(mef) mef %*% M_U_ct)) rm(MEF_list) UWTWU_list <- Map(function(uw, twu) uw %*% twu, uw = UW_list, twu = TWU_list) Omega_ct <- t(chol(M_U %*% Reduce("+", UWTWU_list) %*% M_U)) rm(TWU_list, UWTWU_list) H_array[3,,,] <- unlist(lapply(MEU_list, function(meu) meu %*% Omega_ct)) rm(MEU_list, Omega_ct) } list(G = G_list, H = H_array) } #-------------------------- # get P array #-------------------------- get_P_array <- function(GH, all_terms = FALSE) { dims <- dim(GH$H) if (all_terms) { if (length(dims)==3) { P_array <- array(NA, dim = c(dims[1], dims[1], dims[3], dims[3])) for (i in 1:dims[1]) for (j in i:dims[1]) { if (dims[2] == 1L) { tmp <- -tcrossprod(GH$H[i,,], GH$H[j,,]) } else { tmp <- -crossprod(GH$H[i,,], GH$H[j,,]) } diag(tmp) <- diag(tmp) + sapply(GH$G, function(x) sum(x[i,] * x[j,])) P_array[i,j,,] <- tmp if (j > i) P_array[j,i,,] <- t(tmp) } } else { P_array <- array(NA, dim = c(dims[2], dims[2], dims[4], dims[4])) for (i in 1:dims[2]) for (j in i:dims[2]) { tmp <- crossprod(GH$H[3,i,,], GH$H[3,j,,]) - crossprod(GH$H[1,i,,], GH$H[2,j,,]) - crossprod(GH$H[2,i,,], GH$H[1,j,,]) diag(tmp) <- diag(tmp) + sapply(GH$G, function(x) sum(x[i,] * x[j,])) P_array[i,j,,] <- tmp if (j > i) P_array[j,i,,] <- t(tmp) } } } else { if (length(dims)==3) { P_array <- array(-apply(GH$H, 1, crossprod), dim = c(dims[3], dims[3], dims[1])) P_diag <- matrix(sapply(GH$G, function(x) rowSums(x^2)), nrow = dims[1], ncol = dims[3]) for (i in 1:dims[1]) diag(P_array[,,i]) <- diag(P_array[,,i]) + P_diag[i,] } else { if (dims[3] == 1L) { P_array <- array(apply(GH$H, 2, function(h) { uf <- tcrossprod(h[1,1,], h[2,1,]) tcrossprod(h[3,1,]) - uf - t(uf) }), dim = c(dims[4], dims[4], dims[2])) } else { P_array <- array(apply(GH$H, 2, function(h) { uf <- crossprod(h[1,,], h[2,,]) crossprod(h[3,,]) - uf - t(uf) }), dim = c(dims[4], dims[4], dims[2])) } P_diag <- matrix(sapply(GH$G, function(x) rowSums(x^2)), nrow = dims[2], ncol = dims[4]) for (i in 1:dims[2]) diag(P_array[,,i]) <- diag(P_array[,,i]) + P_diag[i,] } } P_array } #-------------------------- # get S array #-------------------------- Sj <- function(M, e, u, tc, cl, cluster, MUWTheta_cholT) { s <- -u %*% MUWTheta_cholT s[,cluster==cl] <- tc + s[,cluster==cl] M %*% e %*% s } get_S_array <- function(obj, vcov) { cluster <- attr(vcov, "cluster") M <- attr(vcov, "bread") / attr(vcov, "v_scale") E_list <- adjust_est_mats(type = attr(vcov, "type"), est_mats = attr(vcov, "est_mats"), adjustments = attr(vcov, "adjustments")) target <- attr(vcov, "target") inverse_var <- attr(vcov, "inverse_var") ignore_FE <- attr(vcov, "ignore_FE") N <- length(cluster) J <- nlevels(cluster) X <- model_matrix(obj) alias <- is.na(coef_CS(obj)) if (any(alias)) X <- X[, !alias, drop = FALSE] p <- ncol(X) S <- augmented_model_matrix(obj, cluster, inverse_var, ignore_FE) if (is.null(S)) { U <- X } else { U <- cbind(X, S) } U_list <- matrix_list(U, cluster, "row") W_list <- weightMatrix(obj, cluster) UW_list <- Map(function(u, w) as.matrix(t(u) %*% w), u = U_list, w = W_list) UWU_list <- Map(function(uw, u) uw %*% u, uw = UW_list, u = U_list) M_U <- chol2inv(chol(Reduce("+",UWU_list))) Theta_cholT <- lapply(target, function(x) t(chol(x))) UWThetaC_list <- Map(function(uw, tc) uw %*% tc, uw = UW_list, tc = Theta_cholT) MUWTheta_cholT <- M_U %*% (matrix(unlist(UWThetaC_list), ncol(U), N)[,order(order(cluster))]) S_list <- mapply(Sj, e = E_list, u = U_list, tc = Theta_cholT, cl = levels(cluster), MoreArgs = list(M = M, cluster=cluster, MUWTheta_cholT=MUWTheta_cholT), SIMPLIFY = FALSE) array(unlist(S_list), dim = c(p, N, J)) } clubSandwich/R/data-documentation.R0000644000176200001440000001655414635054652017011 0ustar liggesusers#' Achievement Awards Demonstration program #' #' Data from a randomized trial of the Achievement Awards #' Demonstration program, reported in Angrist & Lavy (2009). #' #' @format A data frame with 16526 rows and 21 variables: \describe{ #' \item{school_id}{Fictitious school identification number} #' \item{school_type}{Factor identifying the school type (Arab religious, Jewish religious, Jewish secular)} #' \item{pair}{Number of treatment pair. Note that 7 is a triple.} #' \item{treated}{Indicator for whether school was in treatment group} #' \item{year}{Cohort year} #' \item{student_id}{Fictitious student identification number} #' \item{sex}{Factor identifying student sex} #' \item{siblings}{Number of siblings} #' \item{immigrant}{Indicator for immigrant status} #' \item{father_ed}{Father's level of education} #' \item{mother_ed}{Mother's level of education} #' \item{Bagrut_status}{Indicator for Bagrut attainment} #' \item{attempted}{Number of Bagrut units attempted} #' \item{awarded}{Number of Bagrut units awarded} #' \item{achv_math}{Indicator for satisfaction of math requirement} #' \item{achv_english}{Indicator for satisfaction of English requirement} #' \item{achv_hebrew}{Indicator for satisfaction of Hebrew requirement} #' \item{lagscore}{Lagged Bagrut score} #' \item{qrtl}{Quartile within distribution of lagscore, calculated by cohort and sex} #' \item{half}{Lower or upper half within distribution of lagscore, calculated by cohort and sex} #' } #' #' @source \href{https://economics.mit.edu/people/faculty/josh-angrist/angrist-data-archive}{Angrist Data Archive} #' #' @references Angrist, J. D., & Lavy, V. (2009). The effects of high stakes #' high school achievement awards : Evidence from a randomized trial. #' \emph{American Economic Review, 99}(4), 1384-1414. #' \doi{10.1257/aer.99.4.1384} #' "AchievementAwardsRCT" #' Dropout prevention/intervention program effects #' #' A dataset containing estimated effect sizes, variances, and covariates from a #' meta-analysis of dropout prevention/intervention program effects, conducted #' by Wilson et al. (2011). Missing observations were imputed. #' #' @format A data frame with 385 rows and 18 variables: \describe{ #' \item{LOR1}{log-odds ratio measuring the intervention effect} #' \item{varLOR}{estimated sampling variance of the log-odds ratio} #' \item{studyID}{unique identifier for each study} \item{studySample}{unique #' identifier for each sample within a study} \item{study_design}{study design #' (randomized, matched, or non-randomized and unmatched)} #' \item{outcome}{outcome measure for the intervention effect is estimated #' (school dropout, school enrollment, graduation, graduation or GED receipt)} #' \item{evaluator_independence}{degree of evaluator independence #' (independent, indirect but influential, involved in planning but not #' delivery, involved in delivery)} \item{implementation_quality}{level of #' implementation quality (clear problems, possible problems, no apparent #' problems)} \item{program_site}{Program delivery site (community, mixed, #' school classroom, school but outside of classroom)} #' \item{attrition}{Overall attrition (proportion)} #' \item{group_equivalence}{pretest group-equivalence log-odds ratio} #' \item{adjusted}{adjusted or unadjusted data used to calculate intervention #' effect} \item{male_pct}{proportion of the sample that is male} #' \item{white_pct}{proportion of the sample that is white} #' \item{average_age}{average age of the sample} \item{duration}{program #' duration (in weeks)} \item{service_hrs}{program contact hours per week} #' \item{big_study}{indicator for the 32 studies with 3 or more effect sizes} #' } #' #' @source Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & #' Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: #' Effects on school completion and dropout Among school-aged children and #' youth: A systematic review. _Campbell Systematic Reviews, 7_(1), 1-61. #' \doi{10.4073/csr.2011.8} #' #' @references Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & #' Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: #' Effects on school completion and dropout Among school-aged children and #' youth: A systematic review. _Campbell Systematic Reviews, 7_(1), 1-61. #' \doi{10.4073/csr.2011.8} #' #' Tipton, E., & Pustejovsky, J. E. (2015). Small-sample adjustments for tests #' of moderators and model fit using robust variance estimation in #' meta-regression. _Journal of Educational and Behavioral Statistics, 40_(6), 604-634. #' \doi{10.3102/1076998615606099} #' "dropoutPrevention" #' State-level annual mortality rates by cause among 18-20 year-olds #' #' A dataset containing state-level annual mortality rates for select causes of #' death, as well as data related to the minimum legal drinking age and alcohol #' consumption. #' #' @format A data frame with 5508 rows and 12 variables: \describe{ #' \item{year}{Year of observation} #' \item{state}{identifier for state} #' \item{count}{Number of deaths} #' \item{pop}{Population size} #' \item{legal}{Proportion of 18-20 year-old population that is legally allowed to drink} #' \item{beertaxa}{Beer taxation rate} #' \item{beerpercap}{Beer consumption per capita} #' \item{winepercap}{Wine consumption per capita} #' \item{spiritpercap}{Spirits consumption per capita} #' \item{totpercap}{Total alcohol consumption per capita} #' \item{mrate}{Mortality rate per 10,000} #' \item{cause}{Cause of death} #' } #' #' @source #' \href{https://masteringmetrics.com/wp-content/uploads/2015/01/deaths.dta}{Mastering #' 'Metrics data archive} #' #' @references #' #' Angrist, J. D., and Pischke, J. S. (2014). _Mastering'metrics: the path from #' cause to effect_. Princeton University Press, 2014. #' #' Carpenter, C., & Dobkin, C. (2011). The minimum legal drinking age and public #' health. _Journal of Economic Perspectives, 25_(2), 133-156. #' \doi{10.1257/jep.25.2.133} #' "MortalityRates" #' Randomized experiments on SAT coaching #' #' Effect sizes from studies on the effects of SAT coaching, #' reported in Kalaian and Raudenbush (1996) #' #' @format A data frame with 67 rows and 11 variables: #' \describe{ #' \item{study}{Study identifier} #' \item{year}{Year of publication} #' \item{test}{Character string indicating whether effect size corresponds to outcome on verbal (SATV) or math (SATM) test} #' \item{d}{Effect size estimate (Standardized mean difference)} #' \item{V}{Variance of effect size estimate} #' \item{nT}{Sample size in treatment condition} #' \item{nC}{Sample size in control condition} #' \item{study_type}{Character string indicating whether study design used a matched, non-equivalent, or randomized control group} #' \item{hrs}{Hours of coaching} #' \item{ETS}{Indicator variable for Educational Testing Service} #' \item{homework}{Indicator variable for homework} #' } #' #' @references Kalaian, H. A. & Raudenbush, S. W. (1996). A multivariate mixed #' linear model for meta-analysis. \emph{Psychological Methods, 1}(3), #' 227-235. #' \doi{10.1037/1082-989X.1.3.227} #' "SATcoaching" clubSandwich/R/utilities.R0000644000176200001440000001273514630154051015226 0ustar liggesusers#----------------------------------------------------- # check that bread can be re-constructed from X and W #----------------------------------------------------- check_bread <- function(obj, cluster, y, check_coef = TRUE, tol = 10^-6) { cluster <- droplevels(as.factor(cluster)) B <- sandwich::bread(obj) / v_scale(obj) X_list <- matrix_list(model_matrix(obj), cluster, "row") W_list <- weightMatrix(obj, cluster) XWX <- Reduce("+", Map(function(x, w) t(x) %*% w %*% x, x = X_list, w = W_list)) M <- chol2inv(chol(XWX)) attr(M, "dimnames") <- attr(B, "dimnames") eq_bread <- diff(range((B / M)[XWX != 0])) < tol if (check_coef) { coef <- coef_CS(obj) y_list <- split(y, cluster) XWy <- Reduce("+", Map(function(x, w, y) t(x) %*% w %*% y, x = X_list, w = W_list, y = y_list)) beta <- as.vector(solve(XWX,XWy)) names(beta) <- names(coef) eq_coef <- all.equal(beta, coef, tol = tol) if (all(c(eq_coef, eq_bread) == TRUE)) TRUE else list(M = M, B = B, beta = beta, coef = coef) } else { if (eq_bread) TRUE else list(M = M, B = B) } } #---------------------------------------------- # check that CR2 and CR4 are target-unbiased #---------------------------------------------- check_CR <- function(obj, vcov, ..., tol = .Machine$double.eps^0.5) { if (is.character(vcov)) vcov <- vcovCR(obj, type = vcov, ...) if (!("clubSandwich" %in% class(vcov))) stop("Variance-covariance matrix must be a clubSandwich.") # calculate E(V^CRj) cluster <- attr(vcov, "cluster") S_array <- get_S_array(obj, vcov) if (dim(S_array)[1] == 1L) { E_CRj <- lapply(1:nlevels(cluster), function(j) crossprod(S_array[1,,j])) } else { E_CRj <- lapply(1:nlevels(cluster), function(j) tcrossprod(S_array[,,j])) } # calculate target Theta_list <- attr(vcov, "target") X <- model_matrix(obj) alias <- is.na(coef_CS(obj)) if (any(alias)) X <- X[, !alias, drop = FALSE] p <- NCOL(X) N <- length(cluster) J <- nlevels(cluster) X_list <- matrix_list(X, cluster, "row") W_list <- weightMatrix(obj, cluster) XW_list <- Map(function(x, w) as.matrix(t(x) %*% w), x = X_list, w = W_list) M <- attr(vcov, "bread") / attr(vcov, "v_scale") attr(M, "dimnames") <- NULL MXWTWXM <- Map(function(xw, theta) M %*% as.matrix(xw %*% theta %*% t(xw)) %*% M, xw = XW_list, theta = Theta_list) eq <- all.equal(E_CRj, MXWTWXM, tolerance = tol) if (all(eq==TRUE)) TRUE else list(E_CRj = E_CRj, target = MXWTWXM) } check_sort_order <- function(obj, dat, cluster = NULL, arrange = NULL, CR_types = paste0("CR",0:3), tol = 10^-6, tol2 = tol, tol3 = tol, seed = NULL) { if (!is.null(seed)) set.seed(seed) re_order <- sample(nrow(dat)) dat_scramble <- dat[re_order,] if (!is.null(arrange)) dat_scramble <- dat_scramble[order(dat_scramble[[arrange]]),] obj_scramble <- update(obj, data = dat_scramble) constraints <- utils::combn(length(coef_CS(obj)), 2, simplify = FALSE) constraint_mats <- lapply(constraints, constrain_zero, coefs = coef_CS(obj)) if (is.null(cluster)) { CR_fit <- lapply(CR_types, function(x) vcovCR(obj, type = x)) CR_scramble <- lapply(CR_types, function(x) vcovCR(obj_scramble, type = x)) test_fit <- lapply(CR_types, function(x) coef_test(obj, vcov = x, test = "All", p_values = FALSE)) test_scramble <- lapply(CR_types, function(x) coef_test(obj_scramble, vcov = x, test = "All", p_values = FALSE)) Wald_fit <- Wald_test(obj, constraints = constraint_mats, vcov = "CR2", test = "All") Wald_scramble <- Wald_test(obj_scramble, constraints = constraint_mats, vcov = "CR2", test = "All") } else { CR_fit <- lapply(CR_types, function(x) vcovCR(obj, cluster = dat[[cluster]], type = x)) CR_scramble <- lapply(CR_types, function(x) vcovCR(obj_scramble, cluster = dat_scramble[[cluster]], type = x)) test_fit <- lapply(CR_types, function(x) coef_test(obj, vcov = x, cluster = dat[[cluster]], test = "All", p_values = FALSE)) test_scramble <- lapply(CR_types, function(x) coef_test(obj_scramble, vcov = x, cluster = dat_scramble[[cluster]], test = "All", p_values = FALSE)) Wald_fit <- Wald_test(obj, constraints = constraint_mats, vcov = "CR2", cluster = dat[[cluster]], test = "All") Wald_scramble <- Wald_test(obj_scramble, constraints = constraint_mats, vcov = "CR2", cluster = dat_scramble[[cluster]], test = "All") } testthat::expect_equivalent(CR_fit, CR_scramble, tolerance = tol) compare_ttests(test_fit, test_scramble, tol = tol2) compare_Waldtests(Wald_fit, Wald_scramble, tol = tol3) } compare_ttests <- function(a, b, tol = 10^-6) { if (!inherits(a,"data.frame")) a <- do.call(rbind, a) if (!inherits(b,"data.frame")) b <- do.call(rbind, b) testthat::expect_equal(a$beta, b$beta, tolerance = tol) testthat::expect_equal(a$SE, b$SE, tolerance = tol) testthat::expect_equal(a$df, b$df, tolerance = tol) testthat::expect_equal(a$saddlepoint, b$saddlepoint, tolerance = tol) } compare_Waldtests <- function(a, b, tol = 10^-4) { if (!inherits(a,"data.frame")) a <- do.call(rbind, a) if (!inherits(b,"data.frame")) b <- do.call(rbind, b) testthat::expect_equal(a$Fstat, b$Fstat, tolerance = tol) testthat::expect_equal(a$df, b$df, tolerance = tol) }clubSandwich/R/coef_test.R0000644000176200001440000002267614630154051015173 0ustar liggesusers #--------------------------------------------- # Satterthwaite approximation #--------------------------------------------- Satterthwaite <- function(beta, SE, P_array) { V_coef <- 2 * apply(P_array, 3, function(x) sum(x^2)) E_coef <- apply(P_array, 3, function(x) sum(diag(x))) df <- 2 * E_coef^2 / V_coef p_val <- 2 * pt(abs(beta / SE), df = df, lower.tail = FALSE) data.frame(df = df, p_Satt = p_val) } #--------------------------------------------- # Saddlepoint approximation #--------------------------------------------- saddlepoint_pval <- function(t, Q) { eig <- pmax(0, eigen(Q, symmetric = TRUE, only.values=TRUE)$values) g <- c(1, -t^2 * eig / sum(eig)) s_eq <- function(s) sum(g / (1 - 2 * g * s)) s_range <- if (t^2 < 1) c(1 / (2 * min(g)), 0) else c(0, 1 / (2 * max(g))) s <- uniroot(s_eq, s_range)$root if (abs(s) > .01) { r <- sign(s) * sqrt(sum(log(1 - 2 * g * s))) q <- s * sqrt(2 * sum(g^2 / (1 - 2 * g * s)^2)) p_val <- 1 - pnorm(r) - dnorm(r) * (1 / r - 1 / q) } else { p_val <- 0.5 - sum(g^3) / (3 * sqrt(pi) * sum(g^2)^(3/2)) } c(s = s, p_val = p_val) } saddlepoint <- function(t_stats, P_array) { saddles <- sapply(1:length(t_stats), function(i) saddlepoint_pval(t = t_stats[i], Q = P_array[,,i])) data.frame(saddlepoint = saddles["s",], p_saddle = saddles["p_val",]) } #--------------------------------------------- # find which coefficients to test #--------------------------------------------- get_which_coef <- function(beta, coefs) { p <- length(beta) if (identical(coefs,"All")) return(rep(TRUE, p)) switch(class(coefs), character = { term_names <- names(beta) if (length(coefs) == 0) stop("You must specify at least one coefficient to test.") if (any(!coefs %in% term_names)) stop("Coefficient names not in model specification.") term_names %in% coefs }, logical = { if (sum(coefs) == 0) stop("You must specify at least one coefficient to test.") if (length(coefs) != p) stop(paste0("Coefficient vector must be of length ",p, ".")) coefs }, numeric = { if (any(!(coefs %in% 1:p))) stop(paste0("Coefficient indices must be less than or equal to ",p,".")) if (length(coefs) == 0) stop("You must specify at least one coefficient to test.") (1:p) %in% coefs }, integer = { if (any(!(coefs %in% 1:p))) stop(paste0("Coefficient indices must be less than or equal to ",p,".")) if (length(coefs) == 0) stop("You must specify at least one coefficient to test.") (1:p) %in% coefs } ) } #--------------------------------------------- # coeftest for all model coefficients #--------------------------------------------- #' Test all or selected regression coefficients in a fitted model #' #' \code{coef_test} reports t-tests for each coefficient estimate in a fitted #' linear regression model, using a sandwich estimator for the standard errors #' and a small sample correction for the p-value. The small-sample correction is #' based on a Satterthwaite approximation or a saddlepoint approximation. #' #' @param obj Fitted model for which to calculate t-tests. #' @param vcov Variance covariance matrix estimated using \code{vcovCR} or a #' character string specifying which small-sample adjustment should be used to #' calculate the variance-covariance. #' @param test Character vector specifying which small-sample corrections to #' calculate. \code{"z"} returns a z test (i.e., using a standard normal #' reference distribution). \code{"naive-t"} returns a t test with \code{m - #' 1} degrees of freedom, where \code{m} is the number of unique clusters. #' \code{"naive-tp"} returns a t test with \code{m - p} degrees of freedom, #' where \code{p} is the number of regression coefficients in \code{obj}. #' \code{"Satterthwaite"} returns a Satterthwaite correction. #' \code{"saddlepoint"} returns a saddlepoint correction. Default is #' \code{"Satterthwaite"}. #' @param coefs Character, integer, or logical vector specifying which #' coefficients should be tested. The default value \code{"All"} will test all #' estimated coefficients. #' @param p_values Logical indicating whether to report p-values. The default #' value is \code{TRUE}. #' @param ... Further arguments passed to \code{\link{vcovCR}}, which are only #' needed if \code{vcov} is a character string. #' #' @return A data frame containing estimated regression coefficients, standard #' errors, and test results. For the Satterthwaite approximation, degrees of #' freedom and a p-value are reported. For the saddlepoint approximation, the #' saddlepoint and a p-value are reported. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' data("ChickWeight", package = "datasets") #' lm_fit <- lm(weight ~ Diet * Time, data = ChickWeight) #' diet_index <- grepl("Diet.:Time", names(coef(lm_fit))) #' coef_test(lm_fit, vcov = "CR2", cluster = ChickWeight$Chick, coefs = diet_index) #' #' V_CR2 <- vcovCR(lm_fit, cluster = ChickWeight$Chick, type = "CR2") #' coef_test(lm_fit, vcov = V_CR2, coefs = diet_index) #' #' @export coef_test <- function(obj, vcov, test = "Satterthwaite", coefs = "All", p_values = TRUE, ...) { beta_full <- coef_CS(obj) beta_NA <- is.na(beta_full) p <- sum(!beta_NA) which_beta <- get_which_coef(beta_full, coefs) beta <- beta_full[which_beta & !beta_NA] if (is.character(vcov)) vcov <- vcovCR(obj, type = vcov, ...) if (!inherits(vcov, "clubSandwich")) stop("Variance-covariance matrix must be a clubSandwich.") all_tests <- c("z","naive-t","naive-tp","Satterthwaite","saddlepoint") if (all(test == "All")) test <- all_tests test <- match.arg(test, all_tests, several.ok = TRUE) SE <- sqrt(diag(vcov))[which_beta[!beta_NA]] if (any(c("Satterthwaite","saddlepoint") %in% test)) { P_array <- get_P_array(get_GH(obj, vcov))[,,which_beta[!beta_NA],drop=FALSE] } result <- data.frame(Coef = names(beta), beta = as.numeric(beta)) result$SE <- SE result$tstat <- beta / SE row.names(result) <- result$Coef if ("z" %in% test) { result$df_z <- Inf result$p_z <- 2 * pnorm(abs(result$tstat), lower.tail = FALSE) } if ("naive-t" %in% test) { J <- nlevels(attr(vcov, "cluster")) result$df_t <- J - 1 result$p_t <- 2 * pt(abs(result$tstat), df = J - 1, lower.tail = FALSE) } if ("naive-tp" %in% test) { J <- nlevels(attr(vcov, "cluster")) result$df_tp <- J - p result$p_tp <- 2 * pt(abs(result$tstat), df = J - p, lower.tail = FALSE) } if ("Satterthwaite" %in% test) { Satt <- Satterthwaite(beta = beta, SE = SE, P_array = P_array) result$df_Satt <- Satt$df result$p_Satt <- Satt$p_Satt } if ("saddlepoint" %in% test) { saddle <- saddlepoint(t_stats = beta / SE, P_array = P_array) result$saddlepoint <- saddle$saddlepoint result$p_saddle <-saddle$p_saddle } class(result) <- c("coef_test_clubSandwich", class(result)) attr(result, "type") <- attr(vcov, "type") if (p_values) { result } else { which_vars <- !grepl("p_", names(result)) result[which_vars] } } #--------------------------------------------- # print method for coef_test #--------------------------------------------- #' @export print.coef_test_clubSandwich <- function(x, digits = 3, ...) { res <- data.frame( `Coef.` = x$Coef, `Estimate` = x$beta, `SE` = x$SE ) res$`t-stat` <- x$tstat if ("p_z" %in% names(x)) { p_z <- format.pval(x$p_z, digits = digits, eps = 10^-digits) Sig_z <- cut(x$p_z, breaks = c(0, 0.001, 0.01, 0.05, 0.1, 1), labels = c("***", "**", "*", ".", " "), include.lowest = TRUE) res <- cbind(res, "d.f. (z)" = x$df_z,"p-val (z)" = p_z, "Sig." = Sig_z) } if ("p_t" %in% names(x)) { p_t <- format.pval(x$p_t, digits = digits, eps = 10^-digits) Sig_t <- cut(x$p_t, breaks = c(0, 0.001, 0.01, 0.05, 0.1, 1), labels = c("***", "**", "*", ".", " "), include.lowest = TRUE) res <- cbind(res, "d.f. (naive-t)" = x$df_t, "p-val (naive-t)" = p_t, "Sig." = Sig_t) } if ("p_tp" %in% names(x)) { p_tp <- format.pval(x$p_tp, digits = digits, eps = 10^-digits) Sig_tp <- cut(x$p_tp, breaks = c(0, 0.001, 0.01, 0.05, 0.1, 1), labels = c("***", "**", "*", ".", " "), include.lowest = TRUE) res <- cbind(res, "d.f. (naive-tp)" = x$df_tp, "p-val (naive-tp)" = p_tp, "Sig." = Sig_tp) } if ("p_Satt" %in% names(x)) { p_Satt <- format.pval(x$p_Satt, digits = digits, eps = 10^-digits) Sig_Satt <- cut(x$p_Satt, breaks = c(0, 0.001, 0.01, 0.05, 0.1, 1), labels = c("***", "**", "*", ".", " "), include.lowest = TRUE) res <- cbind(res, "d.f. (Satt)" = x$df_Satt, "p-val (Satt)" = p_Satt, "Sig." = Sig_Satt) } if ("p_saddle" %in% names(x)) { p_saddle <- format.pval(x$p_saddle, digits = digits, eps = 10^-digits) Sig_saddle <- cut(x$p_saddle, breaks = c(0, 0.001, 0.01, 0.05, 0.1, 1), labels = c("***", "**", "*", ".", " "), include.lowest = TRUE) res <- cbind(res, "s.p." = x$saddlepoint, "p-val (Saddle)" = p_saddle, "Sig." = Sig_saddle) } print(format(res, digits = 3), row.names = FALSE) } clubSandwich/R/lm.R0000644000176200001440000000516714630154051013624 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for an lm object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from an \code{\link{lm}} object. #' #' @param cluster Expression or vector indicating which observations belong to #' the same cluster. Required for \code{lm} objects. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If a vector, the target matrix is assumed to be #' diagonal. If not specified, the target is taken to be an identity matrix. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' data("ChickWeight", package = "datasets") #' lm_fit <- lm(weight ~ Time + Diet:Time, data = ChickWeight) #' vcovCR(lm_fit, cluster = ChickWeight$Chick, type = "CR2") #' #' if (requireNamespace("plm", quietly = TRUE)) withAutoprint({ #' #' data("Produc", package = "plm") #' lm_individual <- lm(log(gsp) ~ 0 + state + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) #' individual_index <- !grepl("state", names(coef(lm_individual))) #' vcovCR(lm_individual, cluster = Produc$state, type = "CR2")[individual_index,individual_index] #' #' # compare to plm() #' plm_FE <- plm::plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, #' data = Produc, index = c("state","year"), #' effect = "individual", model = "within") #' vcovCR(plm_FE, type="CR2") #' #' }) #' #' @export vcovCR.lm <- function(obj, cluster, type, target = NULL, inverse_var = NULL, form = "sandwich", ...) { if (missing(cluster)) stop("You must specify a clustering variable.") if (is.null(inverse_var)) inverse_var <- is.null(weights(obj)) & is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # model_matrix() # residuals_CS() # coef() # nobs() # targetVariance() # weightMatrix() #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- # bread.lm() is in sandwich package #' @export v_scale.lm <- function(obj) { as.vector(sum(summary(obj)$df[1:2])) } clubSandwich/R/geeglm.R0000644000176200001440000002057414630154051014453 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a geeglm object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from an \code{\link[geepack]{geeglm}} object. #' #' @param cluster Expression or vector indicating which observations belong to #' the same cluster. Required for \code{geeglm} objects. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If a vector, the target matrix is assumed to be #' diagonal. If not specified, the target is taken to be the estimated variance function. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("geepack", quietly = TRUE)) { #' #' library(geepack) #' data(dietox, package = "geepack") #' dietox$Cu <- as.factor(dietox$Cu) #' mf <- formula(Weight ~ Cu * (Time + I(Time^2) + I(Time^3))) #' gee1 <- geeglm(mf, data=dietox, id=Pig, family=poisson("identity"), corstr="ar1") #' V_CR <- vcovCR(gee1, cluster = dietox$Pig, type = "CR2") #' coef_test(gee1, vcov = V_CR, test = "Satterthwaite") #' #' } #' #' @export vcovCR.geeglm <- function(obj, cluster, type, target = NULL, inverse_var = NULL, form = "sandwich", ...) { if (missing(cluster)) { cluster <- as.factor(obj$id) names(cluster) <- NULL } if (is.null(inverse_var)) inverse_var <- is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # coef() # nobs() #----------------------------------------------- # Model matrix #----------------------------------------------- #' @export model_matrix.geeglm <- function(obj) { X <- model.matrix(obj) eta <- obj$linear.predictors dmu_deta <- obj$family$mu.eta d <- dmu_deta(eta) d * X } #------------------------------------- # residuals #------------------------------------- #' @export residuals_CS.geeglm <- function(obj) { residuals(obj, type = "response") } #----------------------------------------------- # Get (model-based) working variance matrix #----------------------------------------------- ar1_cor <- function(n, alpha) { exponent <- abs(matrix(1:n - 1, nrow = n, ncol = n, byrow = TRUE) - (1:n - 1)) alpha^exponent } get_dist <- function(v) { mat_dist <- as.matrix(dist(v, diag = TRUE, upper = TRUE)) mat_dist } other_cor <- function(alpha, n = (1 + sqrt(1 + 4 * 2 * length(alpha))) / 2) { x <- matrix(1, nrow = n, ncol = n) x[lower.tri(x)] <- alpha x[upper.tri(x)] <- t(x)[upper.tri(x)] x } #' @export targetVariance.geeglm <- function(obj, cluster) { idvar <- as.factor(obj$id) mu <- fitted.values(obj) var_fun <- obj$family$variance v <- as.numeric(var_fun(mu)) w <- weights(obj, type = "prior") a <- tapply(v / w, idvar, sqrt) aa <- lapply(a, tcrossprod) if (obj$corstr %in% c("independence", "exchangeable", "ar1", "unstructured", "userdefined", "fixed") == F) { stop("Working correlation matrix must be a matrix with the following correlation structures: independence, exchangeable, ar1, unstructured, or userdefined") } else if (obj$corstr == "ar1") { if (is.null(obj$call$waves)) { r <- lapply(obj$geese$clusz, ar1_cor, alpha = obj$geese$alpha) } else { wave <- eval(obj$call$waves, envir = obj$data) wave_vec <- split(wave, ceiling(seq_along(wave) / obj$geese$clusz)) exponent <- lapply(wave_vec, get_dist) get_str <- function(alpha, exponent) { alpha_str <- alpha^exponent alpha_str } r <- lapply(exponent, get_str, alpha = obj$geese$alpha) } } else if (obj$corstr == "unstructured") { r <- lapply(obj$geese$clusz, other_cor, alpha = as.numeric(obj$geese$alpha)) } else if (obj$corstr %in% c("userdefined","fixed")) { formula_env <- attr(obj$formula, ".Environment") if (as.character(obj$call$zcor) %in% objects(formula_env)) { zcor <- eval(obj$call$zcor, envir = formula_env) } else { zcor <- eval(obj$call$zcor, envir = parent.frame()) } id_cor <- table(idvar) id_cor <- rep(names(id_cor), id_cor * (id_cor - 1) / 2) if (obj$corstr == "userdefined") { alpha <- as.numeric(obj$geese$alpha) r_vec <- as.numeric(zcor %*% alpha) r <- tapply(r_vec, id_cor, other_cor) } else if (obj$corstr == "fixed") { r <- tapply(zcor, id_cor, other_cor) } } v <- mapply("*", aa, r, SIMPLIFY = FALSE) v <- nest_bdiag(v, crosswalk = data.frame(idvar, as.factor(cluster))) v } ##################### #------------------------------------- # Get weighting matrix #------------------------------------- ar1_cor_inv <- function(n, alpha) { if (n == 1) { matrix(1) } else { r_inv <- diag(c(1,rep(1 + alpha^2, n - 2), 1), nrow = n) index <- cbind(2:n, 1:(n-1)) r_inv[index] <- r_inv[index[,2:1]] <- -alpha r_inv } } exch_inv <- function(n, alpha) { diag(1 / (1 - alpha), nrow = n) - alpha / ((1 - alpha) * (alpha * (n - 1) + 1)) } #' @export weightMatrix.geeglm <- function(obj, cluster) { idvar <- as.factor(obj$id) if (obj$corstr %in% c("independence", "exchangeable", "ar1", "unstructured", "userdefined", "fixed") == F) { stop("Working correlation matrix must be a matrix with the following correlation structures: independence, exchangeable, ar1, unstructured, or userdefined") } else if (obj$corstr %in% c("unstructured","userdefined", "fixed")) { # Invert the targetVariance for unstructured or user-defined working models V_list <- targetVariance.geeglm(obj, idvar) W_list <- lapply(V_list, function(v) chol2inv(chol(v))) } else { # Otherwise use analytic formulas for inverse of targetVariance mu <- fitted.values(obj) var_fun <- obj$family$variance v <- as.numeric(var_fun(mu)) w <- weights(obj, type = "prior") if (obj$corstr %in% c("exchangeable","ar1")) { a <- tapply(w / v, idvar, sqrt) aa <- lapply(a, tcrossprod) if (obj$corstr == "ar1") { if (is.null(obj$call$waves)) { r_inv <- lapply(obj$geese$clusz, ar1_cor_inv, alpha = obj$geese$alpha) } else { wave <- eval(obj$call$waves, envir = obj$data) wave_vec <- split(wave, ceiling(seq_along(wave) / obj$geese$clusz)) exponent <- lapply(wave_vec, get_dist) get_str <- function(alpha, exponent) { alpha_str <- alpha^exponent alpha_str } r <- lapply(exponent, get_str, alpha = obj$geese$alpha) r_inv <- lapply(r, function(x) chol2inv(chol(x))) } } else if (obj$corstr == "exchangeable") { r_inv <- lapply(obj$geese$clusz, exch_inv, alpha = obj$geese$alpha) } W_list <- mapply("*", aa, r_inv, SIMPLIFY = FALSE) } else { W_list <- matrix_list(w / v, idvar, dim = "both") } } W_list <- nest_bdiag(W_list, crosswalk = data.frame(idvar, as.factor(cluster))) return(W_list) } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.geeglm <- function(x, ...) { cluster <- droplevels(as.factor(x$id)) X <- model_matrix(x) X_list <- matrix_list(X, cluster, "row") W_list <- weightMatrix(x, cluster) XWX <- Reduce("+", Map(function(x, w) t(x) %*% w %*% x, x = X_list, w = W_list)) M <- chol2inv(chol(XWX / v_scale(x))) rownames(M) <- colnames(M) <- colnames(X) M } #' @export v_scale.geeglm <- function(obj) { if (substr(obj$family$family, 1, 17) %in% c("poisson", "binomial", "Negative Binomial")) { dispersion <- 1 } else { wres <- as.vector(residuals(obj, "working")) * weights(obj, "working") dispersion <- sum(wres^2)/sum(weights(obj, "working")) } as.vector(sum(summary(obj)$df[1:2])) * dispersion } clubSandwich/R/rma-mv.R0000644000176200001440000005655014635054536014431 0ustar liggesusers #---------------------------------------------------------------------- # utility function for computing block-diagonal covariance matrices #---------------------------------------------------------------------- isPosDef <- function(x) { x_na <- is.na(x) mis_rows <- apply(x_na, 1, all) mis_cols <- apply(x_na, 2, all) if (all(mis_rows) | all(mis_cols)) return(TRUE) x_nomiss <- x[!mis_rows, !mis_cols] x_eig <- eigen(x_nomiss) all(x_eig$values > 0) } check_PD <- function(vcov_list) { PD <- sapply(vcov_list, isPosDef) if (!all(PD)) { NPD_clusters <- names(vcov_list)[!PD] warn_text <- paste(c("The following clusters have non-positive definite covariance matrices:", NPD_clusters), collapse = "\n") warning(warn_text) } else { NULL } } #' Impute a block-diagonal covariance matrix #' #' @description `r lifecycle::badge("superseded")` #' #' This function is superseded by the \code{\link[metafor]{vcalc}} provided by #' the \code{metafor} package. Compared to \code{impute_covariance_matrix}, #' \code{\link[metafor]{vcalc}} provides many further features, includes a #' \code{data} argument, and uses syntax that is consistent with other #' functions in \code{metafor}. #' #' \code{impute_covariance_matrix} calculates a block-diagonal covariance #' matrix, given the marginal variances, the block structure, and an assumed #' correlation structure. Can be used to create compound-symmetric structures, #' AR(1) auto-correlated structures, or combinations thereof. #' #' @param vi Vector of variances #' @param cluster Vector indicating which effects belong to the same cluster. #' Effects with the same value of `cluster` will be treated as correlated. #' @param r Vector or numeric value of assumed constant correlation(s) between #' effect size estimates from each study. #' @param ti Vector of time-points describing temporal spacing of effects, for #' use with auto-regressive correlation structures. #' @param ar1 Vector or numeric value of assumed AR(1) auto-correlation(s) #' between effect size estimates from each study. If specified, then \code{ti} #' argument must be specified. #' @param smooth_vi Logical indicating whether to smooth the marginal variances #' by taking the average \code{vi} within each cluster. Defaults to #' \code{FALSE}. #' @param subgroup Vector of category labels describing sub-groups of effects. #' If non-null, effects that share the same category label and the same #' cluster will be treated as correlated, but effects with different category #' labels will be treated as uncorrelated, even if they come from the same #' cluster. #' @param return_list Optional logical indicating whether to return a list of #' matrices (with one entry per block) or the full variance-covariance matrix. #' @param check_PD Optional logical indicating whether to check whether each #' covariance matrix is positive definite. If \code{TRUE} (the default), the #' function will display a warning if any covariance matrix is not positive #' definite. #' #' #' #' @return If \code{cluster} is appropriately sorted, then a list of matrices, #' with one entry per cluster, will be returned by default. If \code{cluster} #' is out of order, then the full variance-covariance matrix will be returned #' by default. The output structure can be controlled with the optional #' \code{return_list} argument. #' #' @details A block-diagonal variance-covariance matrix (possibly represented as #' a list of matrices) with a specified structure. The structure depends on #' whether the \code{r} argument, \code{ar1} argument, or both arguments are #' specified. Let \eqn{v_{ij}}{v-ij} denote the specified variance for effect #' \eqn{i}{i} in cluster \eqn{j}{j} and \eqn{C_{hij}}{C-hij} be the covariance #' between effects \eqn{h}{h} and \eqn{i}{i} in cluster #' \eqn{j}{j}. #' \itemize{ #' \item{If only \code{r} is specified, each block of the variance-covariance #' matrix will have a constant (compound symmetric) correlation, so that #' \deqn{C_{hij} = r_j \sqrt{v_{hj} v_{ij},}}{C-hij = r-j * sqrt(v-hj v-ij),} #' where \eqn{r_j}{r-j} is the specified correlation #' for cluster \eqn{j}{j}. If only a single value is given in \code{r}, then #' it will be used for every cluster.} #' \item{If only \code{ar1} is specified, each block of the variance-covariance matrix will have an #' AR(1) auto-correlation structure, so that #' \deqn{C_{hij} = \phi_j^{|t_{hj}- t_{ij}|} \sqrt{v_{hj} v_{ij},}}{C-hij = (ar1-j)^|t-hj - t-ij| * sqrt(v-hj v-ij),} #' where \eqn{\phi_j}{ar1-j} is the specified auto-correlation #' for cluster \eqn{j}{j} and \eqn{t_{hj}}{t-hj} and \eqn{t_{ij}}{t-ij} #' are specified time-points corresponding to effects \eqn{h}{h} and #' \eqn{i}{i} in cluster \eqn{j}{j}. If only a single value is given in #' \code{ar1}, then it will be used for every cluster.} #' \item{If both \code{r} and \code{ar1} are specified, each block of the variance-covariance matrix will have combination of compound symmetric and an AR(1) #' auto-correlation structures, so that #' \deqn{C_{hij} = \left[r_j + (1 - r_j)\phi_j^{|t_{hj} - t_{ij}|}\right] \sqrt{v_{hj} v_{ij},}}{C-hij = [r-j + (1 - r-j)(ar1-j)^|t-hj - t-ij|] * sqrt(v-hj v-ij),} #' where \eqn{r_j}{r-j} is the specified constant correlation for cluster #' \eqn{j}{j}, \eqn{\phi_j}{ar1-j} is the specified auto-correlation for #' cluster \eqn{j}{j} and \eqn{t_{hj}}{t-hj} and \eqn{t_{ij}}{t-ij} are #' specified time-points corresponding to effects \eqn{h}{h} and #' \eqn{i}{i} in cluster \eqn{j}{j}. If only single values are given in #' \code{r} or \code{ar1}, they will be used for every cluster.} #' } #' If \code{smooth_vi = TRUE}, then all of the variances within cluster #' \eqn{j}{j} will be set equal to the average variance of cluster #' \eqn{j}{j}, i.e., \deqn{v'_{ij} = \frac{1}{n_j} \sum_{i=1}^{n_j} #' v_{ij}}{v-ij' = (v-1j + ... + v-nj,j) / n-j} for #' \eqn{i=1,...,n_j}{i=1,...,n-j} and \eqn{j=1,...,k}{j=1,...,k}. #' #' @export #' #' @examples #' #' if (requireNamespace("metafor", quietly = TRUE)) { #' #' library(metafor) #' #' # Constant correlation #' data(SATcoaching) #' V_list <- impute_covariance_matrix(vi = SATcoaching$V, cluster = SATcoaching$study, r = 0.66) #' MVFE <- rma.mv(d ~ 0 + test, V = V_list, data = SATcoaching) #' conf_int(MVFE, vcov = "CR2", cluster = SATcoaching$study) #' #' } #' impute_covariance_matrix <- function(vi, cluster, r, ti, ar1, smooth_vi = FALSE, subgroup = NULL, return_list = identical(as.factor(cluster), sort(as.factor(cluster))), check_PD = TRUE) { lifecycle::deprecate_soft("0.5.11", "impute_covariance_matrix()", "metaffor::vcalc()") cluster <- droplevels(as.factor(cluster)) vi_list <- split(vi, cluster) if (smooth_vi) vi_list <- lapply(vi_list, function(x) rep(mean(x, na.rm = TRUE), length(x))) if (missing(r) & missing(ar1)) stop("You must specify a value for r or for ar1.") if (!missing(r)) { r_list <- rep_len(r, length(vi_list)) if (missing(ar1)) { vcov_list <- Map(function(V, rho) (rho + diag(1 - rho, nrow = length(V))) * tcrossprod(sqrt(V)), V = vi_list, rho = r_list) } } if (!missing(ar1)) { if (missing(ti)) stop("If you specify a value for ar1, you must provide a vector for ti.") ti_list <- split(ti, cluster) ar_list <- rep_len(ar1, length(vi_list)) if (missing(r)) { vcov_list <- Map(function(V, time, phi) (phi^as.matrix(stats::dist(time))) * tcrossprod(sqrt(V)), V = vi_list, time = ti_list, phi = ar_list) } else { vcov_list <- Map(function(V, rho, time, phi) (rho + (1 - rho) * phi^as.matrix(stats::dist(time))) * tcrossprod(sqrt(V)), V = vi_list, rho = r_list, time = ti_list, phi = ar_list) } vcov_list <- lapply(vcov_list, function(x) { attr(x, "dimnames") <- NULL x }) } if (!is.null(subgroup)) { si_list <- split(subgroup, cluster) subgroup_list <- lapply(si_list, function(x) sapply(x, function(y) y == x)) vcov_list <- Map(function(V, S) V * S, V = vcov_list, S = subgroup_list) } if (check_PD) check_PD(vcov_list) if (return_list) { return(vcov_list) } else { vcov_mat <- unblock(vcov_list) cluster_index <- order(order(cluster)) return(vcov_mat[cluster_index, cluster_index]) } } #' Impute a patterned block-diagonal covariance matrix #' #' @description `r lifecycle::badge("superseded")` #' #' This function is superseded by the \code{\link[metafor]{vcalc}} provided by #' the \code{metafor} package. Compared to \code{pattern_covariance_matrix}, #' \code{\link[metafor]{vcalc}} provides many further features, includes a #' \code{data} argument, and uses syntax that is consistent with other #' functions in \code{metafor}. #' #' @description \code{pattern_covariance_matrix} calculates a #' block-diagonal covariance matrix, given the marginal variances, the block #' structure, and an assumed correlation structure defined by a patterned #' correlation matrix. #' #' @param vi Vector of variances #' @param cluster Vector indicating which effects belong to the same cluster. #' Effects with the same value of `cluster` will be treated as correlated. #' @param pattern_level Vector of categories for each effect size, used to #' determine which entry of the pattern matrix will be used to impute a #' correlation. #' @param r_pattern Patterned correlation matrix with row and column names #' corresponding to the levels of \code{pattern}. #' @inheritParams impute_covariance_matrix #' #' @return If \code{cluster} is appropriately sorted, then a list of matrices, #' with one entry per cluster, will be returned by default. If \code{cluster} #' is out of order, then the full variance-covariance matrix will be returned #' by default. The output structure can be controlled with the optional #' \code{return_list} argument. #' #' @details A block-diagonal variance-covariance matrix (possibly represented as #' a list of matrices) with a specified correlation structure, defined by a #' patterned correlation matrix. Let \eqn{v_{ij}}{v-ij} denote the specified #' variance for effect \eqn{i}{i} in cluster \eqn{j}{j} and #' \eqn{C_{hij}}{C-hij} be the covariance between effects \eqn{h}{h} and #' \eqn{i}{i} in cluster \eqn{j}{j}. Let \eqn{p_{ij}}{p-ij} be the level #' of the pattern variable for effect \eqn{i}{i} in cluster \eqn{j}{j}, #' taking a value in \eqn{1,...,C}{1,...,C}. A patterned correlation matrix #' is defined as a set of correlations between pairs of effects taking each #' possible combination of patterns. Formally, let \eqn{r_{cd}}{r-cd} be the #' correlation between effects in categories \eqn{c}{c} and \eqn{d}{d}, #' respectively, where \eqn{r_{cd} = r_{dc}}{r-cd = r-dc}. Then the #' covariance between effects \eqn{h}{h} and \eqn{i}{i} in cluster #' \eqn{j}{j} is taken to be \deqn{C_{hij} = \sqrt{v_{hj} v_{ij}} \times #' r_{p_{hj} p_{ij}}.}{C-hij = sqrt(v-hj v-ij) * r[p-hj, p-ij].} #' #' Correlations between effect sizes within the same category are defined by the diagonal #' values of the pattern matrix, which may take values less than one. #' #' Combinations of pattern levels that do not occur in the patterned correlation matrix will be set equal to \code{r}. #' #' If \code{smooth_vi = TRUE}, then all of the variances within cluster #' \eqn{j}{j} will be set equal to the average variance of cluster #' \eqn{j}{j}, i.e., \deqn{v'_{ij} = \frac{1}{n_j} \sum_{i=1}^{n_j} #' v_{ij}}{v-ij' = (v-1j + ... + v-nj,j) / n-j} for #' \eqn{i=1,...,n_j}{i=1,...,n-j} and \eqn{j=1,...,k}{j=1,...,k}. #' #' @export #' #' @examples #' #' pkgs_available <- #' requireNamespace("metafor", quietly = TRUE) & #' requireNamespace("robumeta", quietly = TRUE) #' #' if (pkgs_available) { #' library(metafor) #' #' data(oswald2013, package = "robumeta") #' dat <- escalc(data = oswald2013, measure = "ZCOR", ri = R, ni = N) #' subset_ids <- unique(dat$Study)[1:20] #' dat <- subset(dat, Study %in% subset_ids) #' #' # make a patterned correlation matrix #' #' p_levels <- levels(dat$Crit.Cat) #' r_pattern <- 0.7^as.matrix(dist(1:length(p_levels))) #' diag(r_pattern) <- seq(0.75, 0.95, length.out = 6) #' rownames(r_pattern) <- colnames(r_pattern) <- p_levels #' #' # impute the covariance matrix using patterned correlations #' V_list <- pattern_covariance_matrix(vi = dat$vi, #' cluster = dat$Study, #' pattern_level = dat$Crit.Cat, #' r_pattern = r_pattern, #' smooth_vi = TRUE) #' #' # fit a model using imputed covariance matrix #' #' MVFE <- rma.mv(yi ~ 0 + Crit.Cat, V = V_list, #' random = ~ Crit.Cat | Study, #' data = dat) #' #' conf_int(MVFE, vcov = "CR2") #' #' } #' pattern_covariance_matrix <- function(vi, cluster, pattern_level, r_pattern, r, smooth_vi = FALSE, subgroup = NULL, return_list = identical(as.factor(cluster), sort(as.factor(cluster))), check_PD = TRUE) { lifecycle::deprecate_soft("0.5.11", "impute_covariance_matrix()", "metaffor::vcalc()") if (missing(pattern_level)) stop("You must specify a vector for pattern_level.") if (any(is.na(pattern_level[!is.na(vi)]))) stop("The pattern_level vector cannot have missing values.") pattern_level <- as.factor(pattern_level) if (!identical(rownames(r_pattern),colnames(r_pattern))) stop("Row names of r_pattern must be identical to column names.") mat_levels <- rownames(r_pattern) p_levels <- levels(pattern_level) if (!all(p_levels %in% mat_levels)) { if (missing(r)) stop("At least one pattern_level is not available in r_pattern. Please specify a value for the r argument.") np_levels <- nlevels(pattern_level) r_pattern_full <- matrix(r, nrow = np_levels, ncol = np_levels) rownames(r_pattern_full) <- colnames(r_pattern_full) <- p_levels included_levels <- intersect(mat_levels, p_levels) r_pattern_full[included_levels, included_levels] <- r_pattern[included_levels, included_levels] r_pattern <- r_pattern_full } cluster <- droplevels(as.factor(cluster)) pattern_list <- split(pattern_level, cluster) cor_list <- lapply(pattern_list, function(x) { res <- r_pattern[x, x, drop=FALSE] diag(res) <- 1 res }) vi_list <- split(vi, cluster) if (smooth_vi) vi_list <- lapply(vi_list, function(x) rep(mean(x, na.rm = TRUE), length(x))) vcov_list <- Map(function(V, r_mat) r_mat * tcrossprod(sqrt(V)), V = vi_list, r_mat = cor_list) if (!is.null(subgroup)) { si_list <- split(subgroup, cluster) subgroup_list <- lapply(si_list, function(x) sapply(x, function(y) y == x)) vcov_list <- Map(function(V, S) V * S, V = vcov_list, S = subgroup_list) } if (check_PD) check_PD(vcov_list) if (return_list) { return(vcov_list) } else { vcov_mat <- unblock(vcov_list) cluster_index <- order(order(cluster)) return(vcov_mat[cluster_index, cluster_index]) } } #------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a rma.mv object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from a #' \code{\link[metafor]{rma.mv}} object. #' #' @param cluster Optional expression or vector indicating which observations #' belong to the same cluster. If not specified, will be set to the factor in #' the random-effects structure with the fewest distinct levels. Caveat #' emptor: the function does not check that the random effects are nested. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be the #' estimated variance-covariance structure of the \code{rma.mv} object. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @export #' #' @examples #' #' pkgs_available <- #' requireNamespace("metafor", quietly = TRUE) & #' requireNamespace("metadat", quietly = TRUE) #' #' if (pkgs_available) withAutoprint({ #' #' library(metafor) #' data(dat.assink2016, package = "metadat") #' #' mfor_fit <- rma.mv(yi ~ year + deltype, #' V = vi, random = ~ 1 | study / esid, #' data = dat.assink2016) #' mfor_fit #' #' mfor_CR2 <- vcovCR(mfor_fit, type = "CR2") #' mfor_CR2 #' #' coef_test(mfor_fit, vcov = mfor_CR2, test = c("Satterthwaite", "saddlepoint")) #' Wald_test(mfor_fit, constraints = constrain_zero(3:4), vcov = mfor_CR2) #' #' }) #' vcovCR.rma.mv <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { if (obj$withR) stop("vcovCR.rma.mv() does not work with fixed correlation matrices in the R argument.") if (missing(cluster)) { cluster <- findCluster.rma.mv(obj) } else { # check that random effects are nested within clustering variable mod_struct <- parse_structure(obj) if (length(cluster) != NROW(mod_struct$cluster_dat)) { cluster <- cluster[obj$not.na] } nested <- test_nested(cluster, fac = mod_struct$cluster_dat) if (!all(nested)) stop("Random effects are not nested within clustering variable.") } if (missing(target)) { target <- NULL inverse_var <- is.null(obj$W) } else { if (missing(inverse_var)) inverse_var <- FALSE } vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # coef() # residuals_CS() # vcov() # model_matrix #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- #' @export targetVariance.rma.mv <- function(obj, cluster) { tV <- matrix_list(obj$M, cluster, "both") if (!all(sapply(tV, is.matrix))) tV <- lapply(tV, as.matrix) return(tV) } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.rma.mv <- function(obj, cluster) { if (is.null(obj$W)) { V_list <- targetVariance(obj, cluster) Wm <- lapply(V_list, function(v) chol2inv(chol(v))) } else{ Wm <- matrix_list(obj$W, cluster, "both") if (!all(sapply(Wm, is.matrix))) Wm <- lapply(Wm, as.matrix) } return(Wm) } #----------------------------------------------- # Get outer-most clustering variable #----------------------------------------------- get_structure <- function(obj) { data.frame(G = obj$withG, H = obj$withH, R = obj$withR, S = obj$withS) } test_nested <- function(cluster, fac) { if (is.list(fac)) { res <- sapply(fac, test_nested, cluster = cluster) return(res) } groupings <- tapply(cluster, fac, function(x) length(unique(x))) all(groupings==1L) } nest_structure <- function(x) { if (length(x) == 1) return(x) y <- x for (i in 2:length(x)) { names(y)[i] <- paste(names(x)[1:i], collapse = "/") y[i] <- do.call(paste, c(x[1:i], sep = "/")) } y } parse_structure <- function(obj) { level_dat <- vector(mode = "integer") cluster_dat <- data.frame(row.names = 1:obj$k) if (obj$withG) { level_dat[["G"]] <- obj$g.nlevels[[2]] cluster_dat$G <- obj$mf.g$outer } if (obj$withH) { level_dat[["H"]] <- obj$h.nlevels[[2]] cluster_dat$H <- obj$mf.h$outer } if (obj$withS) { s_levels <- obj$s.nlevels names(s_levels) <- obj$s.names level_dat <- c(level_dat, s_levels) mf_r <- lapply(obj$mf.r, nest_structure) mf_all <- do.call(cbind, mf_r) mf_s <- mf_all[obj$s.names] cluster_dat <- cbind(cluster_dat, mf_s) cluster_dat <- droplevels(cluster_dat) } list(level_dat = level_dat, cluster_dat = cluster_dat) } #' Detect cluster structure of an rma.mv object #' #' \code{findCluster.rma.mv} returns a vector of ID variables for the highest level of clustering in a fitted \code{rma.mv} model. #' #' @param obj A fitted \code{rma.mv} object. #' #' @return A a vector of ID variables for the highest level of clustering in \code{obj}. #' #' @export #' #' @examples #' #' if (requireNamespace("metafor", quietly = TRUE)) { #' #' library(metafor) #' data(dat.assink2016, package = "metadat") #' #' mfor_fit <- rma.mv(yi ~ year + deltype, #' V = vi, random = ~ 1 | study / esid, #' data = dat.assink2016) #' #' findCluster.rma.mv(mfor_fit) #' #' } #' findCluster.rma.mv <- function(obj) { if (!inherits(obj, "rma.mv")) stop("`obj` must be a fitted rma.mv model.") if (obj$withR) stop("vcovCR.rma.mv() does not work with fixed correlation matrices in the R argument.") # parse model structure mod_struct <- parse_structure(obj) if (length(mod_struct$level_dat) == 0L) stop("No clustering variable specified.") # determine cluster with smallest number of levels highest_cluster <- names(mod_struct$level_dat)[which.min(mod_struct$level_dat)] cluster <- mod_struct$cluster_dat[[highest_cluster]] # check that random effects are nested within clustering variable nested <- test_nested(cluster, fac = mod_struct$cluster_dat) if (!all(nested)) stop("Random effects are not nested within clustering") # clean up if (!is.factor(cluster)) cluster <- as.factor(cluster) droplevels(cluster) } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.rma.mv <- function(x, ...) { if (inherits(x, "robust.rma")) { cluster <- findCluster.rma.mv(x) W <- weightMatrix(x, cluster = cluster) X_mat <- model_matrix(x) X_list <- matrix_list(X_mat, fac = cluster, dim = "row") XWX_list <- Map(function(x, w) t(x) %*% w %*% x, x = X_list, w = W) XWX <- Reduce(`+`, XWX_list) } else { if (is.null(x$W)) { B <- vcov(x) * nobs(x) return(B) } else { X_mat <- model_matrix(x) XWX <- t(X_mat) %*% x$W %*% X_mat } } B <- chol2inv(chol(XWX)) * nobs(x) rownames(B) <- colnames(B) <- colnames(X_mat) return(B) } #' @export v_scale.rma.mv <- function(obj) { nobs(obj) } clubSandwich/R/glm.R0000644000176200001440000000701214630154051013762 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for a glm object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from an \code{\link{glm}} object. #' #' @param cluster Expression or vector indicating which observations belong to #' the same cluster. Required for \code{glm} objects. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If a vector, the target matrix is assumed to be #' diagonal. If not specified, the target is taken to be the estimated variance function. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("geepack", quietly = TRUE)) { #' #' data(dietox, package = "geepack") #' dietox$Cu <- as.factor(dietox$Cu) #' weight_fit <- glm(Weight ~ Cu * poly(Time, 3), data=dietox, family = "quasipoisson") #' V_CR <- vcovCR(weight_fit, cluster = dietox$Pig, type = "CR2") #' coef_test(weight_fit, vcov = V_CR, test = "Satterthwaite") #' #' } #' #' @export vcovCR.glm <- function(obj, cluster, type, target = NULL, inverse_var = NULL, form = "sandwich", ...) { if (missing(cluster)) stop("You must specify a clustering variable.") if (is.null(inverse_var)) inverse_var <- is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # coef() # nobs() #----------------------------------------------- # Model matrix #----------------------------------------------- #' @export model_matrix.glm <- function(obj) { X <- model.matrix(obj) eta <- obj$linear.predictors dmu_deta <- obj$family$mu.eta d <- dmu_deta(eta) d * X } #------------------------------------- # residuals #------------------------------------- #' @export residuals_CS.glm <- function(obj) { residuals(obj, type = "response") } #----------------------------------------------- # Get (model-based) working variance matrix #----------------------------------------------- #' @export targetVariance.glm <- function(obj, cluster) { mu <- fitted.values(obj) var_fun <- obj$family$variance v <- var_fun(mu) w <- weights(obj, type = "prior") matrix_list(v / w, cluster, "both") } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.glm <- function(obj, cluster) { mu <- fitted.values(obj) var_fun <- obj$family$variance v <- var_fun(mu) w <- weights(obj, type = "prior") matrix_list(w / v, cluster, "both") } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- # bread.glm() is in sandwich package #' @export v_scale.glm <- function(obj) { if (substr(obj$family$family, 1, 17) %in% c("poisson", "binomial", "Negative Binomial")) { dispersion <- 1 } else { wres <- as.vector(residuals(obj, "working")) * weights(obj, "working") dispersion <- sum(wres^2)/sum(weights(obj, "working")) } as.vector(sum(summary(obj)$df[1:2])) * dispersion } clubSandwich/R/Wald_test.R0000644000176200001440000005335114630154051015140 0ustar liggesusers#-------------------------------------------------- # helper functions for constructing constraint matrices #-------------------------------------------------- #' @name constraint_matrices #' @title Create constraint matrices #' #' @description Helper functions to create common types of constraint matrices, #' for use with \code{\link{Wald_test}} to conduct Wald-type tests of linear #' contrasts from a fitted regression model. #' #' @param constraints Set of constraints to test. Can be logical (using #' \code{TRUE} to specify which coefficients to constrain), integer (specify #' the index of coefficients to constrain), character (specify the names of #' the coefficients to constrain), or a regular expression. #' @param coefs Vector of coefficient estimates, used to determine the column #' dimension of the constraint matrix. Can be omitted if the function is #' called inside \code{Wald_test()}. #' @param reg_ex Logical indicating whether \code{constraints} should be #' interpreted as a regular expression. Defaults to \code{FALSE}. #' @param with_zero Logical indicating whether coefficients should also be #' compared to zero. Defaults to \code{FALSE}. #' #' @details Constraints can be specified as character vectors, regular #' expressions (with \code{reg_ex = TRUE}), integer vectors, or logical #' vectors. #' #' \code{constrain_zero()} Creates a matrix that constrains a specified set of #' coefficients to all be equal to zero. #' #' \code{constrain_equal()} Creates a matrix that constrains a specified set #' of coefficients to all be equal. #' #' \code{constrain_pairwise()} Creates a list of constraint matrices #' consisting of all pairwise comparisons between a specified set of #' coefficients. If \code{with_zero = TRUE}, then the list will also include a #' set of constraint matrices comparing each coefficient to zero. #' #' @return A matrix or list of matrices encoding the specified set of #' constraints. #' #' @seealso \code{\link{Wald_test}} #' #' @examples #' #' if (requireNamespace("carData", quietly = TRUE)) withAutoprint({ #' #' data(Duncan, package = "carData") #' Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) #' #' Duncan_fit <- lm(prestige ~ 0 + type + income + type:income + type:education, data=Duncan) #' # Note that type:income terms are interactions because main effect of income is included #' # but type:education terms are separate slopes for each unique level of type #' #' Duncan_coefs <- coef(Duncan_fit) #' #' # The following are all equivalent #' constrain_zero(constraints = c("typeprof:income","typewc:income"), #' coefs = Duncan_coefs) #' constrain_zero(constraints = ":income", coefs = Duncan_coefs, #' reg_ex = TRUE) #' constrain_zero(constraints = 5:6, coefs = Duncan_coefs) #' constrain_zero(constraints = c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, FALSE, FALSE, FALSE), #' coefs = Duncan_coefs) #' #' # The following are all equivalent #' constrain_equal(c("typebc:education","typeprof:education","typewc:education"), #' Duncan_coefs) #' constrain_equal(":education", Duncan_coefs, reg_ex = TRUE) #' constrain_equal(7:9, Duncan_coefs) #' constrain_equal(c(FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE,TRUE,TRUE), #' Duncan_coefs) #' #' # Test pairwise equality of the education slopes #' constrain_pairwise(":education", Duncan_coefs, #' reg_ex = TRUE) #' #' # Test pairwise equality of the income slopes, plus compare against zero #' constrain_pairwise(":income", Duncan_coefs, #' reg_ex = TRUE, with_zero = TRUE) #' #' }) #' #' @rdname constraint_matrices #' @export constrain_zero <- function(constraints, coefs, reg_ex = FALSE) { if (missing(coefs)) { f <- function(coefs) constrain_zero(constraints = constraints, coefs = coefs, reg_ex = reg_ex) return(f) } if (is.list(constraints)) { constraint_list <- lapply(constraints, constrain_zero, coefs = coefs, reg_ex = reg_ex) return(constraint_list) } p <- length(coefs) if (reg_ex) { if (!inherits(constraints, "character")) stop("When reg_ex = TRUE, constraints must be a regular expression.") constraints <- grepl(constraints, names(coefs)) } if ((inherits(constraints, "logical") & sum(as.logical(constraints)) < 1L) | length(constraints) < 1L) stop("You must specify at least one constraint.") if (inherits(constraints, "logical")) { if (length(constraints) != p) stop(paste0("Constraint logicals must be of length ",p,".")) C_mat <- diag(1L, nrow = p)[constraints,,drop=FALSE] } if (inherits(constraints, "numeric") | inherits(constraints, "integer")) { if (any(!(constraints %in% 1:p))) stop(paste0("Constraint indices must be less than or equal to ",p,".")) C_mat <- diag(1L, nrow = p)[constraints,,drop=FALSE] } if (inherits(constraints, "character")) { term_names <- names(coefs) if (any(!constraints %in% term_names)) stop("Constraint names not in model specification.") C_mat <- diag(1L, nrow = p)[term_names %in% constraints,,drop=FALSE] } coef_NA <- is.na(coefs) C_mat[,!coef_NA,drop=FALSE] } #' @rdname constraint_matrices #' @export constrain_equal <- function(constraints, coefs, reg_ex = FALSE) { if (missing(coefs)) { f <- function(coefs) constrain_equal(constraints = constraints, coefs = coefs, reg_ex = reg_ex) return(f) } if (is.list(constraints)) { constraint_list <- lapply(constraints, constrain_equal, coefs = coefs, reg_ex = reg_ex) return(constraint_list) } if (reg_ex) { if (!inherits(constraints, "character")) stop("When reg_ex = TRUE, constraints must be a regular expression.") constraints <- grepl(constraints, names(coefs)) } if ((inherits(constraints, "logical") & sum(as.logical(constraints)) < 2L) | length(constraints) < 2L) stop("You must specify at least two constraints.") C_mat <- constrain_zero(constraints = constraints, coefs = coefs) first_constraint <- which(C_mat[1,] > 0) C_mat[,first_constraint] <- -1L C_mat[-1,,drop=FALSE] } #' @rdname constraint_matrices #' @export constrain_pairwise <- function(constraints, coefs, reg_ex = FALSE, with_zero = FALSE) { if (missing(coefs)) { f <- function(coefs) constrain_pairwise(constraints = constraints, coefs = coefs, reg_ex = reg_ex, with_zero = with_zero) return(f) } if (is.list(constraints)) { constraint_list <- lapply(constraints, constrain_pairwise, coefs = coefs, reg_ex = reg_ex, with_zero = with_zero) constraint_list <- unlist(constraint_list, recursive = FALSE) return(constraint_list) } p <- length(coefs) term_names <- names(coefs) if (reg_ex) { if (!inherits(constraints, "character")) stop("When reg_ex = TRUE, constraints must be a regular expression.") constraints <- grepl(constraints, names(coefs)) } if ((inherits(constraints, "logical") & sum(as.logical(constraints)) < 2L) | length(constraints) < 2L) stop("You must specify at least two constraints.") if (inherits(constraints, "logical")) { if (length(constraints) != p) stop(paste0("Constraint logicals must be of length ",p,".")) constraint_indices <- which(constraints) } if (inherits(constraints, "numeric") | inherits(constraints, "integer")) { if (any(!(constraints %in% 1:p))) stop(paste0("Constraint indices must be less than or equal to ",p,".")) constraint_indices <- as.integer(constraints) } if (inherits(constraints, "character")) { if (!all(constraints %in% term_names)) stop("Constraint names not in model specification.") constraint_indices <- which(term_names %in% constraints) } zero_mat <- matrix(0L, nrow = 1, ncol = p) constraint_pairs <- utils::combn(constraint_indices, 2, simplify = FALSE) names(constraint_pairs) <- sapply(constraint_pairs, function(x) paste(term_names[rev(x)], collapse = " - ")) C_mats <- lapply(constraint_pairs, function(x) { zero_mat[,x] <- c(-1L, 1L) zero_mat }) if (with_zero) { names(constraint_indices) <- term_names[constraint_indices] C_to_zero <- lapply(constraint_indices, function(x) { zero_mat[,x] <- 1L zero_mat }) C_mats <- c(C_to_zero, C_mats) } return(C_mats) } #--------------------------------------------- # Wald-type tests #--------------------------------------------- #' Test parameter constraints in a fitted linear regression model #' #' \code{Wald_test} reports Wald-type tests of linear contrasts from a fitted #' linear regression model, using a sandwich estimator for the #' variance-covariance matrix and a small sample correction for the p-value. #' Several different small-sample corrections are available. #' #' @param obj Fitted model for which to calculate Wald tests. #' @param constraints List of one or more constraints to test. See details and #' examples. #' @param vcov Variance covariance matrix estimated using \code{vcovCR} or a #' character string specifying which small-sample adjustment should be used to #' calculate the variance-covariance. #' @param test Character vector specifying which small-sample correction(s) to #' calculate. The following corrections are available: \code{"chi-sq"}, #' \code{"Naive-F"}, \code{"Naive-Fp"}, \code{"HTA"}, \code{"HTB"}, \code{"HTZ"}, \code{"EDF"}, #' \code{"EDT"}. Default is \code{"HTZ"}. #' @param tidy Logical value controlling whether to tidy the test results. If #' \code{constraints} is a list with multiple constraints, the result will #' be coerced into a data frame when \code{tidy = TRUE}. #' @param ... Further arguments passed to \code{\link{vcovCR}}, which are only #' needed if \code{vcov} is a character string. #' #' @details Constraints can be specified directly as q X p matrices or #' indirectly through \code{\link{constrain_equal}}, #' \code{\link{constrain_zero}}, or \code{\link{constrain_pairwise}} #' #' @return A list of test results. #' #' @seealso \code{\link{vcovCR}}, \code{\link{constrain_equal}}, #' \code{\link{constrain_zero}}, \code{\link{constrain_pairwise}} #' #' @examples #' #' #' if (requireNamespace("carData", quietly = TRUE)) withAutoprint({ #' #' data(Duncan, package = "carData") #' Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) #' #' Duncan_fit <- lm(prestige ~ 0 + type + income + type:income + type:education, data=Duncan) #' # Note that type:income terms are interactions because main effect of income is included #' # but type:education terms are separate slopes for each unique level of type #' #' # Test equality of intercepts #' Wald_test(Duncan_fit, #' constraints = constrain_equal(1:3), #' vcov = "CR2", cluster = Duncan$cluster) #' #' # Test equality of type-by-education slopes #' Wald_test(Duncan_fit, #' constraints = constrain_equal(":education", reg_ex = TRUE), #' vcov = "CR2", cluster = Duncan$cluster) #' #' # Pairwise comparisons of type-by-education slopes #' Wald_test(Duncan_fit, #' constraints = constrain_pairwise(":education", reg_ex = TRUE), #' vcov = "CR2", cluster = Duncan$cluster) #' #' # Test type-by-income interactions #' Wald_test(Duncan_fit, #' constraints = constrain_zero(":income", reg_ex = TRUE), #' vcov = "CR2", cluster = Duncan$cluster) #' #' # Pairwise comparisons of type-by-income interactions #' Wald_test(Duncan_fit, #' constraints = constrain_pairwise(":income", reg_ex = TRUE, with_zero = TRUE), #' vcov = "CR2", cluster = Duncan$cluster) #' #' }) #' #' @export Wald_test <- function(obj, constraints, vcov, test = "HTZ", tidy = FALSE, ...) { if (is.character(vcov)) vcov <- vcovCR(obj, type = vcov, ...) if (!inherits(vcov, "clubSandwich")) stop("Variance-covariance matrix must be a clubSandwich.") all_tests <- c("chi-sq","Naive-F","Naive-Fp","HTA","HTB","HTZ","EDF","EDT") if (all(test == "All")) test <- all_tests test <- match.arg(test, all_tests, several.ok = TRUE) beta <- na.omit(coef_CS(obj)) p <- length(beta) GH <- get_GH(obj, vcov) # Evaluate constrain_*() functions if used if (inherits(constraints, "function")) { constraints <- constraints(coef_CS(obj)) } if (is.list(constraints)) { constraints <- lapply(constraints, function(x) { if (inherits(x, "function")) x(coef_CS(obj)) else x }) # List of constraints if (!all(sapply(constraints, inherits, "matrix") & sapply(constraints, ncol) == p)) { stop(paste0("Constraints must be a q X ", p," matrix, a list of such matrices, or a call to a constrain_*() function.")) } results <- lapply(constraints, Wald_testing, beta = beta, vcov = vcov, test = test, p = p, GH = GH, stop_on_NPD = FALSE) if (tidy) { results <- mapply( function(x, nm) cbind(hypothesis = rep(nm, nrow(x)), x, stringsAsFactors = FALSE), x = results, nm = names(results), SIMPLIFY = FALSE ) results <- do.call(rbind, c(results, make.row.names = FALSE)) class(results) <- c("Wald_test_clubSandwich",class(results)) } } else { if (!inherits(constraints, "matrix") | ncol(constraints) != p) { stop(paste0("Constraints must be a q X ", p," matrix, a list of such matrices, or a call to a constrain_*() function.")) } results <- Wald_testing(C_mat = constraints, beta = beta, vcov = vcov, test = test, p = p, GH = GH) } results } array_multiply <- function(mat, arr) { new_mat <- apply(arr, 3, function(s) mat %*% s) array(new_mat, dim = c(nrow(mat), dim(arr)[2], dim(arr)[3])) } Wald_testing <- function(C_mat, beta, vcov, test, p, GH, stop_on_NPD = TRUE) { q <- nrow(C_mat) dims <- dim(GH$H) J <- dims[length(dims)] if (any(c("HTA","HTB","HTZ","EDF","EDT") %in% test)) { GH$G <- lapply(GH$G, function(s) C_mat %*% s) if (length(dims)==3) { GH$H <- array_multiply(C_mat, GH$H) } else { H <- array(NA, dim = c(3, q, dims[3:4])) for (i in 1:dims[1]) H[i,,,] <- array_multiply(C_mat, GH$H[i,,,]) GH$H <- H } P_array <- get_P_array(GH = GH, all_terms = TRUE) Omega <- apply(P_array, 1:2, function(x) sum(diag(x))) Omega_nsqrt <- matrix_power(Omega, -1/2) } # Wald statistic inverse_vcov <- tryCatch( chol2inv(chol(C_mat %*% vcov %*% t(C_mat))), error = function(e) e ) if (inherits(inverse_vcov, "error")) { if (stop_on_NPD) { stop("Variance-covariance matrix of the contrast is not positive definite. The test cannot be computed.") } else { result <- data.frame( test = test, Fstat = NA_real_, delta = NA_real_, df_num = q, df_denom = NA_real_, p_val = NA_real_ ) } } else { C_beta <- C_mat %*% beta Q <- as.numeric(t(C_beta) %*% inverse_vcov %*% C_beta) result <- data.frame() # chi-square if ("chi-sq" %in% test) { p_val <- pchisq(Q, df = q, lower.tail = FALSE) result <- rbind(result, data.frame(test = "chi-sq", Fstat = Q / q, delta = 1, df_num = q, df_denom = Inf, p_val = p_val)) } # Naive F if ("Naive-F" %in% test) { p_val <- pf(Q / q, df1 = q, df2 = J - 1, lower.tail = FALSE) result <- rbind(result, data.frame(test = "Naive-F", Fstat = Q / q, delta = 1, df_num = q, df_denom = J - 1, p_val = p_val)) } # Naive F with J - p degrees of freedom if ("Naive-Fp" %in% test) { p_val <- pf(Q / q, df1 = q, df2 = J - p, lower.tail = FALSE) result <- rbind(result, data.frame(test = "Naive-Fp", Fstat = Q / q, delta = 1, df_num = q, df_denom = J - p, p_val = p_val)) } # Hotelling's T-squared if ("HTA" %in% test | "HTB" %in% test) { Cov_arr <- covariance_array(P_array, Omega_nsqrt, q = q) Var_index <- seq(1,q^4, 1 + q^2) Var_mat <- matrix(Cov_arr[Var_index], q, q) if ("HTA" %in% test) { nu_A <- 2 * sum(Var_mat) / sum(Cov_arr^2) result <- rbind(result, data.frame(test = "HTA", Hotelling_Tsq(Q, q, nu = nu_A))) } if ("HTB" %in% test) { lower_mat <- lower.tri(Var_mat, diag = TRUE) lower_arr <- array(FALSE, dim = dim(Cov_arr)) for (s in 1:q) for (t in 1:s) for (u in 1:s) for (v in 1:(ifelse(u==s,t,u))) lower_arr[s,t,u,v] <- TRUE nu_B <- 2 * sum(Var_mat[lower_mat]) / sum(Cov_arr[lower_arr]^2) result <- rbind(result, data.frame(test = "HTB", Hotelling_Tsq(Q, q, nu = nu_B))) } } else if ("HTZ" %in% test) { Var_mat <- total_variance_mat(P_array, Omega_nsqrt, q = q) } if ("HTZ" %in% test) { nu_Z <- q * (q + 1) / sum(Var_mat) result <- rbind(result, data.frame(test = "HTZ", Hotelling_Tsq(Q, q, nu = nu_Z))) } # Eigen-decompositions if ("EDF" %in% test | "EDT" %in% test) { spec <- eigen(Omega_nsqrt %*% C_mat %*% vcov %*% t(C_mat) %*% t(Omega_nsqrt)) df_eig <- 1 / apply(t(spec$vectors) %*% Omega_nsqrt, 1, function(x) sum(apply(P_array, 3:4, function(P) (t(x) %*% P %*% x)^2))) if ("EDF" %in% test) { df4 <- pmax(df_eig, 4.1) EQ <- sum(df4 / (df4 - 2)) VQ <- 2 * sum(df4^2 * (df4 - 1) / ((df4 - 2)^2 * (df4 - 4))) delta <- ifelse(q * VQ > 2 * EQ^2, (EQ^2 * (q - 2) + 2 * q * VQ) / (EQ * (VQ + EQ^2)), q / EQ) df <- ifelse(q * VQ > 2 * EQ^2, 4 + 2 * EQ^2 * (q + 2) / (q * VQ - 2 * EQ^2), Inf) Fstat <- delta * Q / q p_val <- pf(Fstat, df1 = q, df2 = df, lower.tail = FALSE) result <- rbind(result, data.frame(test = "EDF", Fstat = Fstat, delta = delta, df_num = q, df_denom = df, p_val = p_val)) } if ("EDT" %in% test) { t_j <- t(spec$vectors) %*% Omega_nsqrt %*% C_mat %*% beta / sqrt(spec$values) a_j <- df_eig - 1 / 2 b_j <- 48 * a_j^2 c_j <- sqrt(a_j * log(1 + t_j^2 / df_eig)) z_j <- c_j + (c_j^3 + 3 * c_j) / b_j - (4 * c_j^7 + 33 * c_j^5 + 240 * c_j^3 + 855 * c_j) / (10 * b_j^2 + 8 * b_j * c_j^4 + 1000 * b_j) Fstat <- mean(z_j^2) p_val <- pf(Fstat, df1 = q, df2 = Inf, lower.tail = FALSE) result <- rbind(result, data.frame(test = "EDT", Fstat = Fstat, delta = 1, df_num = q, df_denom = Inf, p_val = p_val)) } } } class(result) <- c("Wald_test_clubSandwich", class(result)) attr(result, "type") <- attr(vcov, "type") result } #-------------------------------------------------- # calculate a covariance array #-------------------------------------------------- covariance_array <- function(P_array, Omega_nsqrt, q = nrow(Omega_nsqrt)) { B_jk <- array(apply(P_array, 3:4, function(p) Omega_nsqrt %*% p %*% Omega_nsqrt), dim = dim(P_array)) Cov_arr <- array(NA, dim = rep(q, 4)) for (s in 1:q) for (t in 1:s) for (u in 1:s) for (v in 1:(ifelse(u==s,t,u))) { temp <- sum(B_jk[s,v,,] * B_jk[t,u,,]) + sum(B_jk[s,u,,] * B_jk[t,v,,]) Cov_arr[s,t,u,v] <- temp Cov_arr[s,t,v,u] <- temp Cov_arr[t,s,u,v] <- temp Cov_arr[t,s,v,u] <- temp Cov_arr[u,v,s,t] <- temp Cov_arr[u,v,t,s] <- temp Cov_arr[v,u,s,t] <- temp Cov_arr[v,u,t,s] <- temp } Cov_arr } #--------------------------------------------------------- # calculate total variance of clubSandwich estimator #--------------------------------------------------------- total_variance_mat <- function(P_array, Omega_nsqrt, q = nrow(Omega_nsqrt)) { B_jk <- array(apply(P_array, 3:4, function(p) Omega_nsqrt %*% p %*% Omega_nsqrt), dim = dim(P_array)) var_mat <- matrix(NA, q, q) for (s in 1:q) for (t in 1:s) { temp <- sum(B_jk[s,t,,] * B_jk[t,s,,]) + sum(B_jk[s,s,,] * B_jk[t,t,,]) var_mat[s,t] <- temp var_mat[t,s] <- temp } var_mat } #-------------------------------------------------- # Hotelling's T-squared approximation #-------------------------------------------------- Hotelling_Tsq <- function(Q, q, nu) { delta <- pmax((nu - q + 1) / nu, 0) df <- nu - q + 1 Fstat <- delta * Q / q p_val <- ifelse(df > 0, pf(Fstat, df1 = q, df2 = df, lower.tail = FALSE), as.numeric(NA)) data.frame(Fstat = Fstat, delta = delta, df_num = q, df_denom = df, p_val = p_val) } #--------------------------------------------- # print method for Wald_test #--------------------------------------------- #' @export print.Wald_test_clubSandwich <- function(x, digits = 3, ...) { res <- x res$delta <- NULL res$p_val <- format.pval(x$p_val, digits = digits, eps = 10^-digits) res$sig <- symnum(x$p_val, corr = FALSE, na = FALSE, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", "**", "*", ".", " ")) print(format(res, digits = 3), row.names = FALSE) } clubSandwich/R/S3-methods.R0000644000176200001440000000524714630154051015141 0ustar liggesusers#---------------------------------------------- # get "working" variance-covariance matrix #---------------------------------------------- targetVariance <- function(obj, cluster) UseMethod("targetVariance") #' @export targetVariance.default <- function(obj, cluster) { matrix_list(rep(1, length(cluster)), cluster, "both") } #---------------------------------------------- # get weighting matrix #---------------------------------------------- weightMatrix <- function(obj, cluster) UseMethod("weightMatrix") #' @export weightMatrix.default <- function(obj, cluster) { weights <- weights(obj) if (is.null(weights)) { weights <- w_scale <- 1 } else { weights <- weights[weights > 0] w_scale <- mean(weights) weights <- weights / w_scale } W <- rep(weights, length.out = length(cluster)) W_list <- matrix_list(W, cluster, "both") attr(W_list, "w_scale") <- w_scale W_list } #---------------------------------------------- # get X matrix #---------------------------------------------- model_matrix <- function(obj) UseMethod("model_matrix") #' @export model_matrix.default <- function(obj) { model_matrix <- model.matrix(obj) w <- obj$weights if (is.null(w) || all(pos_wts <- w > 0)) { return(model_matrix) } else { return(model_matrix[pos_wts > 0,,drop=FALSE]) } } #---------------------------------------------- # get augmented design matrix #---------------------------------------------- augmented_model_matrix <- function(obj, cluster, inverse_var, ignore_FE) UseMethod("augmented_model_matrix") #' @export augmented_model_matrix.default <- function(obj, cluster, inverse_var, ignore_FE) { NULL } #---------------------------------------------- # get residuals #---------------------------------------------- residuals_CS <- function(obj) UseMethod("residuals_CS") #' @export residuals_CS.default <- function(obj) { w <- obj$weights if (is.null(w) || all(pos_wts <- w > 0)) { residuals(obj) } else { residuals(obj)[pos_wts] } } #---------------------------------------------- # get coefficient estimates #---------------------------------------------- coef_CS <- function(obj) UseMethod("coef_CS") #' @export coef_CS.default <- function(obj) { coef(obj) } #---------------------------------------------- # get bread matrix #---------------------------------------------- # bread matrices imported from sandwich package or elsewhere #' @importFrom sandwich bread get_bread <- function(obj) bread(obj) v_scale <- function(obj) UseMethod("v_scale") #' @export v_scale.default <- function(obj) { nobs(obj) } clubSandwich/R/conf_int.R0000644000176200001440000002766414630154051015021 0ustar liggesusers #-------------------------------------------------- # confidence intervals for all model coefficients #--------------------------------------------------- #' Calculate confidence intervals for all or selected regression coefficients in #' a fitted model #' #' \code{conf_int} reports confidence intervals for each coefficient estimate in #' a fitted linear regression model, using a sandwich estimator for the standard #' errors and a small sample correction for the critical values. The #' small-sample correction is based on a Satterthwaite approximation. #' #' @param obj Fitted model for which to calculate confidence intervals. #' @param level Desired coverage level for confidence intervals. #' @param test Character vector specifying which small-sample corrections to #' calculate. \code{"z"} returns a z test (i.e., using a standard normal #' reference distribution). \code{"naive-t"} returns a t test with \code{m - #' 1} degrees of freedom, where \code{m} is the number of unique clusters. #' \code{"naive-tp"} returns a t test with \code{m - p} degrees of freedom, #' where \code{p} is the number of regression coefficients in \code{obj}. #' \code{"Satterthwaite"} returns a Satterthwaite correction. Unlike in #' \code{coef_test()}, \code{"saddlepoint"} is not currently supported in #' \code{conf_int()} because saddlepoint confidence intervals do not have a #' closed-form solution. #' @param p_values Logical indicating whether to report p-values. The default #' value is \code{FALSE}. #' @inheritParams coef_test #' #' @return A data frame containing estimated regression coefficients, standard #' errors, confidence intervals, and (optionally) p-values. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' data("ChickWeight", package = "datasets") #' lm_fit <- lm(weight ~ Diet * Time, data = ChickWeight) #' diet_index <- grepl("Diet.:Time", names(coef(lm_fit))) #' conf_int(lm_fit, vcov = "CR2", cluster = ChickWeight$Chick, coefs = diet_index) #' #' V_CR2 <- vcovCR(lm_fit, cluster = ChickWeight$Chick, type = "CR2") #' conf_int(lm_fit, vcov = V_CR2, level = .99, coefs = diet_index) #' #' @export conf_int <- function(obj, vcov, level = .95, test = "Satterthwaite", coefs = "All", ..., p_values = FALSE) { if (level <= 0 | level >= 1) stop("Confidence level must be between 0 and 1.") beta_full <- coef_CS(obj) beta_NA <- is.na(beta_full) p <- sum(!beta_NA) which_beta <- get_which_coef(beta_full, coefs) beta <- beta_full[which_beta & !beta_NA] if (is.character(vcov)) vcov <- vcovCR(obj, type = vcov, ...) if (!inherits(vcov, "clubSandwich")) stop("Variance-covariance matrix must be a clubSandwich.") all_tests <- c("z","naive-t","naive-tp","Satterthwaite") if (test == "saddlepoint") stop("test = 'saddlepoint' is not currently supported because saddlepoint confidence intervals do not have a closed-form solution.") test <- match.arg(test, all_tests, several.ok = FALSE) SE <- sqrt(diag(vcov))[which_beta[!beta_NA]] if (test=="Satterthwaite") { P_array <- get_P_array(get_GH(obj, vcov))[,,which_beta[!beta_NA],drop=FALSE] } df <- switch(test, z = Inf, `naive-t` = nlevels(attr(vcov, "cluster")) - 1, `naive-tp` = nlevels(attr(vcov, "cluster")) - p, `Satterthwaite` = Satterthwaite(beta = beta, SE = SE, P_array = P_array)$df ) crit <- qt(1 - (1 - level) / 2, df = df) result <- data.frame( Coef = names(beta), beta = beta, SE = SE, df = df, CI_L = beta - SE * crit, CI_U = beta + SE * crit ) row.names(result) <- result$Coef if (p_values) { t_stat <- result$beta / result$SE result$p_val <- 2 * pt(abs(t_stat), df = result$df, lower.tail = FALSE) } class(result) <- c("conf_int_clubSandwich", class(result)) attr(result, "type") <- attr(vcov, "type") attr(result, "level") <- level result } #-------------------------------------------------- # confidence intervals for linear contrasts #--------------------------------------------------- #' Calculate confidence intervals and p-values for linear contrasts of #' regression coefficients in a fitted model #' #' \code{linear_contrast} reports confidence intervals and (optionally) p-values #' for linear contrasts of regression coefficients from a fitted model, using a #' sandwich estimator for the standard errors and (optionally) a small sample #' correction for the critical values. The default small-sample correction is #' based on a Satterthwaite approximation. #' #' @param obj Fitted model for which to calculate confidence intervals. #' @param contrasts A contrast matrix, or a list of multiple contrast matrices #' to test. See details and examples. #' @param level Desired coverage level for confidence intervals. #' @param test Character vector specifying which small-sample corrections to #' calculate. \code{"z"} returns a z test (i.e., using a standard normal #' reference distribution). \code{"naive-t"} returns a t test with \code{m - #' 1} degrees of freedom, where \code{m} is the number of unique clusters. #' \code{"naive-tp"} returns a t test with \code{m - p} degrees of freedom, #' where \code{p} is the number of regression coefficients in \code{obj}. #' \code{"Satterthwaite"} returns a Satterthwaite correction. Unlike in #' \code{coef_test()}, \code{"saddlepoint"} is not currently supported in #' \code{conf_int()} because saddlepoint confidence intervals do not have a #' closed-form solution. #' @param p_values Logical indicating whether to report p-values. The default #' value is \code{FALSE}. #' @inheritParams coef_test #' #' @details Constraints can be specified directly as q X p matrices or #' indirectly through \code{\link{constrain_pairwise}}, #' \code{\link{constrain_equal}}, or \code{\link{constrain_zero}}. #' #' @return A data frame containing estimated contrasts, standard #' errors, confidence intervals, and (optionally) p-values. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' data("ChickWeight", package = "datasets") #' lm_fit <- lm(weight ~ 0 + Diet + Time:Diet, data = ChickWeight) #' #' # Pairwise comparisons of diet-by-time slopes #' linear_contrast(lm_fit, vcov = "CR2", cluster = ChickWeight$Chick, #' contrasts = constrain_pairwise("Diet.:Time", reg_ex = TRUE)) #' #' #' if (requireNamespace("carData", quietly = TRUE)) withAutoprint({ #' #' data(Duncan, package = "carData") #' Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) #' #' Duncan_fit <- lm(prestige ~ 0 + type + income + type:income + type:education, data=Duncan) #' # Note that type:income terms are interactions because main effect of income is included #' # but type:education terms are separate slopes for each unique level of type #' #' # Pairwise comparisons of type-by-education slopes #' linear_contrast(Duncan_fit, vcov = "CR2", cluster = Duncan$cluster, #' contrasts = constrain_pairwise(":education", reg_ex = TRUE), #' test = "Satterthwaite") #' #' # Pairwise comparisons of type-by-income interactions #' linear_contrast(Duncan_fit, vcov = "CR2", cluster = Duncan$cluster, #' contrasts = constrain_pairwise(":income", reg_ex = TRUE, with_zero = TRUE), #' test = "Satterthwaite") #' #' }) #' #' @export linear_contrast <- function(obj, vcov, contrasts, level = .95, test = "Satterthwaite", ..., p_values = FALSE) { if (level <= 0 | level >= 1) stop("Confidence level must be between 0 and 1.") beta_full <- coef_CS(obj) beta_NA <- is.na(beta_full) p <- sum(!beta_NA) beta <- beta_full[!beta_NA] if (is.character(vcov)) vcov <- vcovCR(obj, type = vcov, ...) if (!inherits(vcov, "clubSandwich")) stop("Variance-covariance matrix must be a clubSandwich.") # Evaluate constrain_*() functions if used if (inherits(contrasts, "function")) { contrasts <- contrasts(beta_full) } if (is.list(contrasts)) { contrast_list <- lapply(contrasts, function(x) { if (inherits(x, "function")) x(beta_full) else x }) if (any(sapply(contrast_list, is.list))) { contrast_list <- lapply(contrast_list, function(x) if (is.list(x)) x else list(x)) contrast_list <- do.call(c, args = contrast_list) } # List of contrasts if (!all(sapply(contrast_list, inherits, "matrix") & sapply(contrast_list, ncol) == p)) { stop(paste0("Contrasts must be a q X ", p," matrix, a list of such matrices, or a call to a constrain_*() function.")) } # Add row names to contrasts contrast_list <- mapply(function(x,r) { if (is.null(rownames(x))) { if (nrow(x) > 1) { rownames(x) <- paste(r, 1:nrow(x), sep = ".") } else { rownames(x) <- r } } else { rownames(x) <- paste(r, rownames(x), sep = ".") } return(x) }, x = contrast_list, r = names(contrast_list), SIMPLIFY = FALSE) # Combine into one matrix contrasts <- do.call(rbind, args = contrast_list) } else if (is.matrix(contrasts)) { if (is.null(rownames(contrasts))) { rownames(contrasts) <- paste("Contrast", 1:NROW(contrasts)) } } else if (is.vector(contrasts)) { contrasts <- matrix(contrasts, nrow = 1L) rownames(contrasts) <- "Contrast" } all_tests <- c("z","naive-t","naive-tp","Satterthwaite") if (test == "saddlepoint") stop("test = 'saddlepoint' is not currently supported because saddlepoint confidence intervals do not have a closed-form solution.") test <- match.arg(test, all_tests, several.ok = FALSE) # Calculate contrasts est <- contrasts %*% beta # Standard error of the contrasts vcov_contrasts <- contrasts %*% vcov %*% t(contrasts) SE <- sqrt(diag(vcov_contrasts)) # Satterthwaite degrees of freedom if (test=="Satterthwaite") { q <- nrow(contrasts) GH <- get_GH(obj, vcov) GH$G <- lapply(GH$G, function(s) contrasts %*% s) dims <- dim(GH$H) if (length(dims)==3) { GH$H <- array_multiply(contrasts, GH$H) } else { H <- array(NA, dim = c(3, q, dims[3:4])) for (i in 1:dims[1]) H[i,,,] <- array_multiply(contrasts, GH$H[i,,,,drop=FALSE]) GH$H <- H } P_array <- get_P_array(GH = GH) } df <- switch(test, z = Inf, `naive-t` = nlevels(attr(vcov, "cluster")) - 1, `naive-tp` = nlevels(attr(vcov, "cluster")) - p, `Satterthwaite` = Satterthwaite(beta = est, SE = SE, P_array = P_array)$df ) crit <- qt(1 - (1 - level) / 2, df = df) result <- data.frame( Coef = rownames(contrasts), Est = est, SE = SE, df = df, CI_L = est - SE * crit, CI_U = est + SE * crit ) row.names(result) <- result$Coef if (p_values) { t_stat <- result$Est / result$SE result$p_val <- 2 * pt(abs(t_stat), df = result$df, lower.tail = FALSE) } class(result) <- c("conf_int_clubSandwich", class(result)) attr(result, "type") <- attr(vcov, "type") attr(result, "level") <- level result } #--------------------------------------------- # print method for conf_int #--------------------------------------------- #' @export print.conf_int_clubSandwich <- function(x, digits = 3, ...) { lev <- paste0(100 * attr(x, "level"), "%") res_names <- c("Coef.", "Estimate", "SE", "d.f.", paste(c("Lower", "Upper"), lev, "CI")) if ("p_val" %in% names(x)) { x$Sig <- cut(x$p_val, breaks = c(0, 0.001, 0.01, 0.05, 0.1, 1), labels = c("***", "**", "*", ".", " "), include.lowest = TRUE) x$p_val <- format.pval(x$p_val, digits = digits, eps = 10^-digits) res_names <- c(res_names, "p-value", "Sig.") } names(x) <- res_names print(format(x, digits = 3), row.names = FALSE) } clubSandwich/R/lme.R0000644000176200001440000002364414630154051013771 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for an lme object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from a \code{\link[nlme]{lme}} object. #' #' @param cluster Optional expression or vector indicating which observations #' belong to the same cluster. If not specified, will be set to #' \code{getGroups(obj)}. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be the #' estimated variance-covariance structure of the \code{lme} object. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("nlme", quietly = TRUE)) { #' #' library(nlme) #' rat_weight <- lme(weight ~ Time * Diet, data=BodyWeight, ~ Time | Rat) #' vcovCR(rat_weight, type = "CR2") #' #' } #' #' pkgs_available <- #' requireNamespace("nlme", quietly = TRUE) & #' requireNamespace("mlmRev", quietly = TRUE) #' #' if (pkgs_available) { #' #' data(egsingle, package = "mlmRev") #' subset_ids <- levels(egsingle$schoolid)[1:10] #' egsingle_subset <- subset(egsingle, schoolid %in% subset_ids) #' #' math_model <- lme(math ~ year * size + female + black + hispanic, #' random = list(~ year | schoolid, ~ 1 | childid), #' data = egsingle_subset) #' #' vcovCR(math_model, type = "CR2") #' #' } #' #' @export vcovCR.lme <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { if (missing(cluster)) cluster <- nlme::getGroups(obj, level = 1) if (missing(target)) target <- NULL if (missing(inverse_var)) inverse_var <- is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # nobs() #------------------------------------- # residuals_CS() #------------------------------------- #' @export residuals_CS.lme <- function(obj) residuals(obj, level = 0) #------------------------------------- # coef_CS() #------------------------------------- #' @export coef_CS.lme <- function(obj) nlme::fixef(obj) #------------------------------------- # model_matrix() #------------------------------------- #' @export model_matrix.lme <- function(obj) { dat <- droplevels(get_data(obj)) model.matrix(formula(obj), data = dat) } #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- get_cor_grouping <- function(obj, levels = NULL) { if (!is.null(obj$groups)) { struct <- obj$modelStruct$corStruct if (is.null(struct)) struct <- obj mod_formula <- nlme::getGroupsFormula(struct) grps <- stats::model.frame(mod_formula, data = nlme::getData(obj)) grps <- apply(grps, 1, paste, collapse = "/") if (is.null(levels)) levels <- unique(grps) grps <- factor(grps, levels = levels) } else if (!is.null(obj$modelStruct$corStruct)) { grps <- factor(rep("A",obj$dims$N)) } else { grps <- factor(1:obj$dims$N) } grps } # Construct list of block-diagonal lowest-level var-cov matrices get_sort_order <- function(obj) { groups <- obj$groups if (is.data.frame(groups)) { order(do.call(order, groups)) } else if (!is.null(groups)) { order(order(groups)) } else { 1:obj$dims$N } } build_var_cor_mats <- function(obj) { if (is.null(obj$modelStruct$corStruct)) { # if there is no correlation structure, # then build block-diagonals with first available grouping variable if (is.null(obj$groups)) { # if there are no groups then make diagonal matrix-lists if (is.null(obj$modelStruct$varStruct)) { V_list <- as.list(rep(1, obj$dims$N)) } else { sd_vec <- 1 / as.numeric(nlme::varWeights(obj$modelStruct$varStruct)) V_list <- as.list(sd_vec^2) } grps <- factor(1:obj$dims$N) attr(V_list, "groups") <- grps names(V_list) <- levels(grps) } else { # if there are groups then make block-diagonal matrix-lists if (is.null(obj$modelStruct$varStruct)) { grps <- obj$groups[[1]] V_list <- tapply(rep(1, length(grps)), grps, diag) } else { sort_order <- get_sort_order(obj) sd_vec <- 1 / as.numeric(nlme::varWeights(obj$modelStruct$varStruct))[sort_order] V_list <- tapply(sd_vec^2, obj$groups[[1]], diag) } attr(V_list, "groups") <- obj$groups[[1]] } } else { # if there is a correlation structure, # build block-diagonals according to its grouping structure R_list <- nlme::corMatrix(obj$modelStruct$corStruct) if (!is.list(R_list)) R_list <- list(A = R_list) cor_grps <- attr(obj$modelStruct$corStruct, "groups") missing_grps <- setdiff(levels(cor_grps), names(R_list)) if (length(missing_grps) > 0) { R_full <- rep(list(matrix(1,1,1)), nlevels(cor_grps)) names(R_full) <- levels(cor_grps) R_full[names(R_list)] <- R_list R_list <- R_full } if (is.null(obj$modelStruct$varStruct)) { V_list <- R_list } else { sd_vec <- 1 / as.numeric(nlme::varWeights(obj$modelStruct$varStruct)) sd_list <- split(sd_vec, cor_grps) V_list <- Map(function(R, s) tcrossprod(s) * R, R = R_list, s = sd_list) } grps <- get_cor_grouping(obj) V_list <- V_list[levels(grps)] attr(V_list, "groups") <- grps } return(V_list) } build_RE_mats <- function(obj) { # Get random effects structure all_groups <- rev(obj$groups) if (length(all_groups) == 1) { D_mat <- as.matrix(obj$modelStruct$reStruct[[1]]) Z_mat <- model.matrix(obj$modelStruct$reStruc, nlme::getData(obj)) row.names(Z_mat) <- NULL Z_list <- matrix_list(Z_mat, all_groups[[1]], "row") ZDZ_list <- ZDZt(D_mat, Z_list) attr(ZDZ_list, "groups") <- all_groups[[1]] } else { D_list <- lapply(obj$modelStruct$reStruct, as.matrix) Z_mat <- model.matrix(obj$modelStruct$reStruc, nlme::getData(obj)) Z_names <- sapply(strsplit(colnames(Z_mat), ".", fixed=TRUE), function(x) x[1]) row.names(Z_mat) <- NULL Z_levels <- lapply(names(all_groups), function(x) Z_mat[,x==Z_names,drop=FALSE]) Z_levels <- Map(matrix_list, x = Z_levels, fac = all_groups, dim = "row") ZDZ_lists <- Map(ZDZt, D = D_list, Z_list = Z_levels) for (i in 2:length(all_groups)) { ZDZ_lists[[i]] <- add_bdiag(small_mats = ZDZ_lists[[i-1]], big_mats = ZDZ_lists[[i]], crosswalk = all_groups[c(i-1,i)]) } ZDZ_list <- ZDZ_lists[[i]] attr(ZDZ_list, "groups") <- all_groups[[i]] } ZDZ_list } ZDZt <- function(D, Z_list) { lapply(Z_list, function(z) z %*% D %*% t(z)) } #' @export targetVariance.lme <- function(obj, cluster = nlme::getGroups(obj, level = 1)) { if (inherits(obj, "nlme")) stop("not implemented for \"nlme\" objects") # lowest-level covariance structure V_list <- build_var_cor_mats(obj) # random effects covariance structure ZDZ_list <- build_RE_mats(obj) V_grps <- attr(V_list, "groups") # Check if lowest-level covariance structure is nested within RE structure ZDZ_grps <- attr(ZDZ_list, "groups") group_mapping <- tapply(ZDZ_grps, V_grps, function(x) length(unique(x))) nested <- all(group_mapping == 1L) if (nested) { target_list <- add_bdiag(V_list, ZDZ_list, data.frame(V_grps, ZDZ_grps)) target_grps <- attr(ZDZ_list, "groups") } else { V_mat <- unblock(V_list, block = V_grps) ZDZ_mat <- unblock(ZDZ_list, block = ZDZ_grps) target_list <- V_mat + ZDZ_mat target_grps <- factor(rep("A", nrow(target_list))) } # check if clustering level is higher than highest level of random effects tb_groups <- table(target_grps) tb_cluster <- table(cluster) if (length(tb_groups) < length(tb_cluster) | any(as.vector(tb_groups) != rep(as.vector(tb_cluster), length.out = length(tb_groups))) | any(names(tb_groups) != rep(names(tb_cluster), length.out = length(tb_groups)))) { # check that random effects are nested within clusters tb_cross <- table(target_grps, cluster) nested <- apply(tb_cross, 1, function(x) sum(x > 0) == 1) if (!all(nested)) stop("Random effects are not nested within clustering variable.") # expand target_list to level of clustering crosswalk <- data.frame(target_grps, cluster) target_list <- add_bdiag(small_mats = target_list, big_mats = matrix_list(rep(0, length(cluster)), cluster, dim = "both"), crosswalk = crosswalk) } return(target_list) } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.lme <- function(obj, cluster = nlme::getGroups(obj, level = 1)) { V_list <- targetVariance(obj, cluster) lapply(V_list, function(v) chol2inv(chol(v))) } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.lme <- function(x, ...) { vcov(x) * v_scale(x) / x$sigma^2 } #' @export v_scale.lme <- function(obj) { nlevels(nlme::getGroups(obj)) } clubSandwich/R/lmer.R0000644000176200001440000001156614634640133014160 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for an lmerMod object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from \code{\link[lme4:merMod-class]{merMod}} object. #' #' @param cluster Optional expression or vector indicating which observations #' belong to the same cluster. If not specified, will be set to #' \code{getGroups(obj)}. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be the #' estimated variance-covariance structure of the \code{lmerMod} object. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("lme4", quietly = TRUE)) { #' #' library(lme4) #' sleep_fit <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) #' vcovCR(sleep_fit, type = "CR2") #' #' } #' #' pkgs_available <- #' requireNamespace("lme4", quietly = TRUE) & #' requireNamespace("mlmRev", quietly = TRUE) #' #' if (pkgs_available) { #' #' data(egsingle, package = "mlmRev") #' subset_ids <- levels(egsingle$schoolid)[1:10] #' math_model <- lmer(math ~ year * size + female + black + hispanic #' + (1 | schoolid) + (1 | childid), #' data = egsingle, subset = schoolid %in% subset_ids) #' vcovCR(math_model, type = "CR2") #' } #' #' @export vcovCR.lmerMod <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { if (!is.null(obj@call$weights)) stop("Models with prior weights are not currently supported.") if (missing(cluster)) cluster <- get_outer_group(obj) if(!is_nested_lmerMod(obj, cluster)) stop("Non-nested random effects detected. clubSandwich methods are not available for such models.") if (missing(target)) target <- NULL if (missing(inverse_var)) inverse_var <- is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } #------------------------------------- # check nesting of random effects #------------------------------------- get_outer_group <- function(obj) { group_n <- lme4::getME(obj, "l_i") group_facs <- lme4::getME(obj, "flist") group_facs[[which.min(group_n)]] } check_nested <- function(inner_grp, outer_grp) { n_outer <- tapply(outer_grp, inner_grp, function(x) length(unique(x))) all(n_outer == 1) } is_nested_lmerMod <- function(obj, cluster = get_outer_group(obj)) { group_facs <- lme4::getME(obj, "flist") nested <- vapply(group_facs, check_nested, outer_grp = cluster, FUN.VALUE = TRUE) all(nested) } # nobs() #------------------------------------- # model_matrix() #------------------------------------- #' @export model_matrix.lmerMod <- function(obj) { model_matrix <- model.matrix(obj) } #------------------------------------- # coef_CS() #------------------------------------- #' @export coef_CS.lmerMod <- function(obj) lme4::getME(obj, "fixef") #------------------------------------- # residuals_CS() #------------------------------------- #' @export residuals_CS.lmerMod <- function(obj) { y <- lme4::getME(obj, "y") X <- lme4::getME(obj, "X") beta <- lme4::getME(obj, "fixef") y - as.numeric(X %*% beta) } #------------------------------------- # Get (model-based) working variance matrix #------------------------------------- #' @export targetVariance.lmerMod <- function(obj, cluster = get_outer_group(obj)) { Z_mat <- lme4::getME(obj, "Z") Lambdat <- lme4::getME(obj, "Lambdat") Zlam_list <- matrix_list(Matrix::tcrossprod(Z_mat, Lambdat), fac = cluster, dim = "row") target_list <- lapply(Zlam_list, function(z) Matrix::tcrossprod(z) + Matrix::Diagonal(n = NROW(z))) lapply(target_list, as.matrix) } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.lmerMod <- function(obj, cluster = get_outer_group(obj)) { V_list <- targetVariance(obj, cluster) lapply(V_list, function(v) chol2inv(chol(v))) } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export bread.lmerMod <- function(x, ...) { sigma_sq <- lme4::getME(x, "sigma")^2 as.matrix(vcov(x) * v_scale(x)) / sigma_sq } #' @export v_scale.lmerMod <- function(obj) { min(lme4::getME(obj, "l_i")) } clubSandwich/R/mlm.R0000644000176200001440000001173414630154051013776 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for an mlm object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from an \code{mlm} object. #' #' @param cluster Optional expression or vector indicating which observations #' belong to the same cluster. If not specified, each row of the data will be #' treated as a separate cluster. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If not specified, the target is taken to be an #' identity matrix. #' @inheritParams vcovCR #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' iris_fit <- lm(cbind(Sepal.Length, Sepal.Width) ~ Species + #' Petal.Length + Petal.Width, data = iris) #' Vcluster <- vcovCR(iris_fit, type = "CR2") #' Vcluster #' #' @export vcovCR.mlm <- function(obj, cluster, type, target, inverse_var, form = "sandwich", ...) { resids <- residuals(obj) d <- ncol(resids) N <- nrow(resids) # Cluster by observation if clustering variable is not specified if (missing(cluster)) cluster <- 1:N # Handle omitted observations in the clustering variable if (inherits(na.action(obj), "omit") && length(cluster) != N) { cluster <- cluster[-na.action(obj)] } # Handle weights of zero in the clustering variable if (!is.null(wts <- weights(obj))) { pos_wts <- wts > 0 if (!all(pos_wts)) cluster <- cluster[pos_wts] N <- sum(pos_wts) } if (length(cluster) == N) cluster <- rep(cluster, each = d) if (length(cluster) != d * N) stop("Clustering variable is not correct length.") if (missing(target)) target <- NULL if (missing(inverse_var)) inverse_var <- is.null(weights(obj)) & is.null(target) vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # nobs() #------------------------------------- # residuals #------------------------------------- #' @export residuals_CS.mlm <- function(obj) { w <- obj$weights if (is.null(w) || all(pos_wts <- w > 0)) { res <- residuals(obj) } else { res <- residuals(obj)[pos_wts,,drop=FALSE] } as.vector(t(res)) } #------------------------------------- # model_matrix() #------------------------------------- #' @export model_matrix.mlm <- function(obj) { X <- model.matrix(obj) w <- obj$weights if (!is.null(w) && !all(pos_wts <- w > 0)) { X <- X[pos_wts > 0,,drop=FALSE] } d <- ncol(residuals(obj)) X_mat <- X %x% diag(1L, nrow = d) rownames(X_mat) <- rep(dimnames(X)[[1]], each = d) colnames(X_mat) <- paste(rep(colnames(residuals(obj)), ncol(X)), rep(colnames(X), each = d), sep = ":") i <- unlist(lapply(1:d, function(x) seq(x, ncol(X_mat), d))) X_mat[,i] } #---------------------------------------------- # get "working" variance-covariance matrix #---------------------------------------------- #' @export targetVariance.mlm <- function(obj, cluster) { matrix_list(rep(1, nobs(obj) * ncol(residuals(obj))), cluster, "both") } #------------------------------------- # Get weighting matrix #------------------------------------- #' @export weightMatrix.mlm <- function(obj, cluster) { weights <- weights(obj) if (is.null(weights)) { weights <- w_scale <- 1 } else { weights <- weights[weights > 0] w_scale <- mean(weights) weights <- weights / w_scale } W <- rep(weights, length.out = nobs(obj)) W <- rep(W, each = ncol(residuals(obj))) W_list <- matrix_list(W, cluster, "both") attr(W_list, "w_scale") <- w_scale W_list } #---------------------------------------------- # get coefficient estimates #---------------------------------------------- #' @export coef_CS.mlm <- function(obj) { cf <- coef(obj) res <- as.vector(cf) names(res) <- paste(rep(colnames(cf), each = nrow(cf)), rep(rownames(cf), ncol(cf)), sep = ":") res } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- #' @export #' bread.mlm <- function(x, ...) { if(!is.null(x$na.action)) class(x$na.action) <- "omit" cf <- coef(x) rval <- summary.lm(x) rval <- kronecker( structure(diag(ncol(cf)), .Dimnames = rep.int(list(colnames(cf)), 2L)), structure(rval$cov.unscaled, .Dimnames = rep.int(list(rownames(cf)), 2L)) * as.vector(sum(rval$df[1:2])), make.dimnames = TRUE ) return(rval) } #' @export v_scale.mlm <- function(obj) { nobs(obj) } clubSandwich/R/ivreg.R0000644000176200001440000000765314630154051014332 0ustar liggesusers#------------------------------------- # vcovCR with defaults #------------------------------------- #' Cluster-robust variance-covariance matrix for an ivreg object. #' #' \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix #' of a set of regression coefficient estimates from an ivreg object fitted #' from the \CRANpkg{AER} package or the \CRANpkg{ivreg} package. #' #' @param cluster Expression or vector indicating which observations belong to #' the same cluster. Required for \code{ivreg} objects. #' @param target Optional matrix or vector describing the working #' variance-covariance model used to calculate the \code{CR2} and \code{CR4} #' adjustment matrices. If a vector, the target matrix is assumed to be #' diagonal. If not specified, the target is taken to be an identity matrix. #' @param inverse_var Not used for \code{ivreg} objects. #' @inheritParams vcovCR #' #' @details For any "ivreg" objects fitted via the \code{\link[ivreg]{ivreg}} #' function from the \CRANpkg{ivreg} package, only traditional 2SLS #' regression method (method = "OLS") is supported. #' clubSandwich currently cannot support robust-regression methods such as #' M-estimation (method = "M") or MM-estimation (method = "MM"). #' #' @return An object of class \code{c("vcovCR","clubSandwich")}, which consists #' of a matrix of the estimated variance of and covariances between the #' regression coefficient estimates. #' #' @seealso \code{\link{vcovCR}} #' #' @examples #' #' if (requireNamespace("AER", quietly = TRUE)) withAutoprint({ #' #' library(AER) #' data("CigarettesSW") #' Cigs <- within(CigarettesSW, { #' rprice <- price/cpi #' rincome <- income/population/cpi #' tdiff <- (taxs - tax)/cpi #' }) #' #' iv_fit_AER <- AER::ivreg(log(packs) ~ log(rprice) + log(rincome) | #' log(rincome) + tdiff + I(tax/cpi), data = Cigs) #' vcovCR(iv_fit_AER, cluster = Cigs$state, type = "CR2") #' coef_test(iv_fit_AER, vcov = "CR2", cluster = Cigs$state) #' #' }) #' #' pkgs_available <- #' requireNamespace("AER", quietly = TRUE) & #' requireNamespace("ivreg", quietly = TRUE) #' #' if (pkgs_available) withAutoprint ({ #' #' data("CigarettesSW") #' Cigs <- within(CigarettesSW, { #' rprice <- price/cpi #' rincome <- income/population/cpi #' tdiff <- (taxs - tax)/cpi #' }) #' iv_fit_ivreg <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | #' log(rincome) + tdiff + I(tax/cpi), data = Cigs) #' vcovCR(iv_fit_ivreg, cluster = Cigs$state, type = "CR2") #' coef_test(iv_fit_ivreg, vcov = "CR2", cluster = Cigs$state) #' }) #' #' @export vcovCR.ivreg <- function(obj, cluster, type, target = NULL, inverse_var = FALSE, form = "sandwich", ...) { if (missing(cluster)) stop("You must specify a clustering variable.") if (inverse_var != FALSE) stop("Unfortunately, the inverse_var option is not available for ivreg models.") if (!is.null(obj$method) && obj$method %in% c("M", "MM")) stop("clubSandwich does not currently support ivreg models estimated using method = 'M' or method = 'MM'.") vcov_CR(obj, cluster = cluster, type = type, target = target, inverse_var = inverse_var, form = form) } # residuals_CS() # coef() # targetVariance() # weightMatrix() # v_scale() #---------------------------------------------- # get X matrix #---------------------------------------------- #' @export model_matrix.ivreg <- function(obj) { model_matrix <- model.matrix(obj, component = "projected") w <- obj$weights if (is.null(w) || all(pos_wts <- w > 0)) { return(model_matrix) } else { return(model_matrix[pos_wts > 0,,drop=FALSE]) } } #--------------------------------------- # Get bread matrix and scaling constant #--------------------------------------- # bread.ivreg() is in AER package # use default v_scale()clubSandwich/vignettes/0000755000176200001440000000000014635065010014670 5ustar liggesusersclubSandwich/vignettes/Wald-tests-in-clubSandwich.Rmd0000644000176200001440000005372014630154052022402 0ustar liggesusers--- title: "Wald tests of multiple-constraint null hypotheses" author: "James E. Pustejovsky" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: number_sections: true toc: true bibliography: bibliography.bib csl: apa.csl vignette: > %\VignetteIndexEntry{Wald tests of multiple-constraint null hypotheses} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, echo = FALSE, results = "asis", message = FALSE, warning = FALSE} library(clubSandwich) AER_available <- requireNamespace("AER", quietly = TRUE) knitr::opts_chunk$set(eval = AER_available) if (!AER_available) cat("# Building this vignette requires the AER package. Please install it. {-}") ``` Version 0.5.0 of `clubSandwich` introduced a new syntax for `Wald_test()`, a function for conducting tests of multiple-constraint hypotheses. In previous versions, this function was poorly documented and, consequently, probably little used. This vignette will demonstrate the new syntax. For purposes of illustration, I will use the `STAR` data (available in the `AER` package), which is drawn from a randomized trial evaluating the effects of elementary school class size on student achievement. The data consist of individual-level measures for students in each of several dozen schools. For purposes of illustration, I will look at effects on math performance in first grade. Treatment conditions (the variable called `stark`) were assigned at the classroom level, and consisted of either a) a regular-size class, b) a small-size class, or c) a regular-size class but with the addition of a teacher's aide. In all of what follows, I will cluster standard errors by school in order to allow for generalization to a super-population of schools. ```{r, message = FALSE, warning = FALSE} library(clubSandwich) data(STAR, package = "AER") # clean up a few variables levels(STAR$stark)[3] <- "aide" levels(STAR$schoolk)[1] <- "urban" STAR <- subset(STAR, !is.na(schoolidk), select = c(schoolidk, schoolk, stark, gender, ethnicity, math1, lunchk)) head(STAR) ``` # The Wald test function The `Wald_test()` function can be used to conduct hypothesis tests that involve multiple constraints on the regression coefficients. Consider a linear model for an outcome $Y_{ij}$ regressed on a $1 \times p$ row vector of predictors $\mathbf{x}_{ij}$ (which might include a constant intercept term): $$ Y_{ij} = \mathbf{x}_{ij} \boldsymbol\beta + \epsilon_{ij} $$ The regression coefficient vector is $\boldsymbol\beta$. In quite general terms, a set of constraints on the regression coefficient vector can be expressed in terms of a $q \times p$ matrix $\mathbf{C}$, where each row of $\mathbf{C}$ corresponds to one constraint. A joint null hypothesis is then $H_0: \mathbf{C} \boldsymbol\beta = \mathbf{0}$, where $\mathbf{0}$ is a $q \times 1$ vector of zeros.[^more-general] [^more-general]: In @pustejovsky2018small we used a more general formulation of multiple-constraint null hypotheses, expressed as $H_0: \mathbf{C} \boldsymbol\beta = \mathbf{d}$ for some fixed $q \times 1$ vector $\mathbf{d}$. In practice, it's often possible to modify the $\mathbf{C}$ matrix so that $\mathbf{d}$ can always be set to $\mathbf{0}$. Wald-type test are based on the test statistic $$ Q = \left(\mathbf{C}\boldsymbol{\hat\beta}\right)' \left(\mathbf{C} \mathbf{V}^{CR} \mathbf{C}'\right)^{-1} \left(\mathbf{C}\boldsymbol{\hat\beta}\right), $$ where $\boldsymbol{\hat\beta}$ is the estimated regression coefficient vector and $\mathbf{V}^{CR}$ is a cluster-robust variance matrix. If the number of clusters is sufficiently large, then the distribution of $Q$ under the null hypothesis is approximately $\chi^2(q)$. @tipton2015small investigated a wide range of other approximations to the null distribution of $Q$, many of which are included as options in `Wald_test()`. Based on a large simulation, they (...er...we...) recommended a method called the "approximate Hotelling's $T^2$-Z" test, or "AHZ." This test approximates the distribution of $Q / q$ by a $T^2$ distribution, which is a multiple of an $F$ distribution, with numerator degrees of freedom $q$ and denominator degrees of freedom based on a generalization of the Satterthwaite approximation. The `Wald_test()` function has three main arguments: ```{r} args(Wald_test) ``` * The `obj` argument is used to specify the estimated regression model on which to perform the test, * the `constraints` argument is a $\mathbf{C}$ matrix expressing the set of constraints to test, and * the `vcov` argument is a cluster-robust variance matrix, which is used to construct the test statistic. (Alternately, `vcov` can be the type of cluster-robust variance matrix to construct, in which case it will be computed internally.) By default, `Wald_test()` will use the HTZ small-sample approximation. Other options are available (via the `test` argument) but not recommended for routine use. The optional `tidy` argument will be demonstrated below. ## Testing treatment effects Returning to the STAR data, let's suppose we want to examine differences in math performance across class sizes. This can be done with a simple linear regression model, while clustering the standard errors by `schoolidk`. The estimating equation is $$ \left(\text{Math}\right)_{ij} = \beta_0 + \beta_1 \left(\text{small}\right)_{ij} + \beta_2 \left(\text{aide}\right)_{ij} + e_{ij}, $$ which can be estimated in R as follows: ```{r type-treat} lm_trt <- lm(math1 ~ stark, data = STAR) V_trt <- vcovCR(lm_trt, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_trt, vcov = V_trt) ``` In this estimating equation, the coefficients $\beta_1$ and $\beta_2$ represent treatment effects, or differences in average math scores relative to the reference level of `stark`, which in this case is a regular-size class. The t-statistics and p-values reported by `coef_test` are separate tests of the null hypotheses that each of these coefficients are equal to zero, meaning that there is no difference between the specified treatment condition and the reference level. We might want to instead test the _joint_ null hypothesis that there are no differences among _any_ of the conditions. This null can be expressed by a set of multiple constraints on the parameters: $\beta_1 = 0$ and $\beta_2 = 0$. To test the null hypothesis that $\beta_1 = \beta_2 = 0$ based on the treatment effects model specification, we can use: ```{r} C_trt <- matrix(c(0,0,1,0,0,1), 2, 3) C_trt Wald_test(lm_trt, constraints = C_trt, vcov = V_trt) ``` The result includes details about the form of `test` computed, the $F$-statistic, the numerator and denominator degrees of freedom used to compute the reference distribution, and the $p$-value corresponding to the specified null hypothesis. In this example, $p = `r if (AER_available) format.pval(Wald_test(lm_trt, constraints = C_trt, vcov = V_trt)$p_val, digits = 3)`$, so we can rule out the null hypothesis that there are no differences in math performance across conditions. The representation of null hypotheses as arbitrary constraint matrices is useful for developing theory about how to test such hypotheses, but it is not all that helpful for actually running tests---constructing constraint matrices "by hand" is just too cumbersome of an exercise. Moreover, $\mathbf{C}$ matrices typically follow one of a small number of patterns. Two common use cases are a) constraining a set of $q > 1$ parameters to all be equal to zero and b) constraining a set of $q + 1$ parameters to be equal to a common value. The `clubSandwich` package now includes a set of helper functions to create constraint matrices for these common use cases. ## `constrain_zero()` To constrain a set of $q$ regression coefficients to all be equal to zero, the simplest form of the $\mathbf{C}$ matrix would consist of a set of $q$ rows, where a single entry in each row would be equal to 1 and the remaining entries would all be zero. For the `lm_trt` model, the C matrix would look like this: $$ \mathbf{C} = \left[\begin{array}{ccc} 0 & 1 & 0 \\ 0 & 0 & 1 \end{array} \right], $$ so that $$ \mathbf{C}\boldsymbol\beta = \left[\begin{array}{ccc} 0 & 1 & 0 \\ 0 & 0 & 1 \end{array} \right] \left[\begin{array}{c} \beta_0 \\ \beta_1 \\ \beta_2 \end{array} \right] = \left[\begin{array}{c} \beta_1 \\ \beta_2 \end{array} \right], $$ which is set equal to $\left[\begin{array}{c} 0 \\ 0 \end{array} \right]$. The `constrain_zero()` function will create matrices like this automatically. The function takes two main arguments: ```{r} args(constrain_zero) ``` * The `constraints` argument is used to specify _which_ coefficients in a regression model to set equal to zero. * The `coefs` argument is the set of estimated regression coefficients, for which to calculate the constraints. Constraints can be specified by position index, by name, or via a regular expression. To test the joint null hypothesis that average math performance is equal across the three treatment conditions, we need to constrain the second and third coefficients to zero: ```{r} constrain_zero(2:3, coefs = coef(lm_trt)) ``` Or equivalently: ```{r} constrain_zero(c("starksmall","starkaide"), coefs = coef(lm_trt)) ``` or ```{r} constrain_zero("^stark", coefs = coef(lm_trt), reg_ex = TRUE) ``` Note that if `constraints` is a regular expression, then the `reg_ex` argument needs to be set to `TRUE`. The result of `constrain_zero()` can then be fed into the `Wald_test()` function: ```{r} C_trt <- constrain_zero(2:3, coefs = coef(lm_trt)) Wald_test(lm_trt, constraints = C_trt, vcov = V_trt) ``` To reduce redundancy in the syntax, we can also omit the `coefs` argument to `constrain_zero`, so long as we call it inside of `Wald_test`[^under-the-hood]: ```{r} Wald_test(lm_trt, constraints = constrain_zero(2:3), vcov = V_trt) ``` [^under-the-hood]: How does this work? If we omit the `coefs` argument, `constrain_zero()` acts as a functional, by returning a function equivalent to `function(coefs) constrain_zero(constraints, coefs = coefs)`. If this function is fed into the `constraints` argument of `Wald_test()`, `Wald_test()` recognizes that it is a function and evaluates the function with `coef(obj)`. It's a kinda-sorta hacky substitute for lazy evaluation. If you have suggestions for how to do this more elegantly, please send them my way. ## `constrain_equal()` Another common type of constraints involve setting a set of $q + 1$ regression coefficients to be all equal to a common (but unknown) value ($q + 1$ because it takes $q$ constraints to do this). There are many equivalent ways to express such a set of constraints in terms of a $\mathbf{C}$ matrix. One fairly simple form consists of a set of $q$ rows, where the entry corresponding to one of the coefficients of interest is equal to -1 and the entry corresponding to another coefficient of interest is equal to 1. To see how this works, let's look at a different way of parameterizing our simple model for the STAR data, by using separate intercepts for each treatment condition. The estimating equation would then be $$ \left(\text{Math}\right)_{ij} = \beta_0 \left(\text{regular}\right)_{ij} + \beta_1 \left(\text{small}\right)_{ij} + \beta_2 \left(\text{aide}\right)_{ij} + e_{ij}. $$ This model can be estimated in R by dropping the intercept term: ```{r type-sep} lm_sep <- lm(math1 ~ 0 + stark, data = STAR) V_sep <- vcovCR(lm_sep, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_sep, vcov = V_sep) ``` In this parameterization, the coefficients $\beta_0$, $\beta_1$, and $\beta_2$ represent the average math performance levels of students in each of the treatment conditions. The t-tests and p-values now have a very different interpretation because they pertain to the null hypothesis that the average performance level for a given condition is equal to zero. With this separate-intercepts model, the joint null hypothesis that performance levels are equal across conditions amounts to constraining the intercepts to be equal to each other: $\beta_0 = \beta_1$ and $\beta_0 = \beta_2$ (note that we don't need the constraint $\beta_1 = \beta_2$ because it is implied by the first two). For the `lm_sep` model, which has separate intercepts $\beta_0$, $\beta_1$, and $\beta_2$, the C matrix would look like this: $$ \mathbf{C} = \left[\begin{array}{ccc} -1 & 1 & 0 \\ -1 & 0 & 1 \end{array} \right], $$ so that $$ \mathbf{C}\boldsymbol\beta = \left[\begin{array}{ccc} -1 & 1 & 0 \\ -1 & 0 & 1 \end{array} \right] \left[\begin{array}{c} \beta_0 \\ \beta_1 \\ \beta_2 \end{array} \right] = \left[\begin{array}{c} \beta_1 - \beta_0 \\ \beta_2 - \beta_0 \end{array} \right], $$ which is set equal to $\left[\begin{array}{c} 0 \\ 0 \end{array} \right]$. The `constrain_equal()` function will create matrices like this automatically, given a set of coefficients to constrain. The syntax is identical to `constrain_zero()`: ```{r} args(constrain_equal) ``` To test the joint null hypothesis that average math performance is equal across the three treatment conditions, we can constrain all three coefficients of `lm_sep` to be equal: ```{r} constrain_equal(1:3, coefs = coef(lm_sep)) ``` Or equivalently: ```{r} constrain_equal(c("starkregular","starksmall","starkaide"), coefs = coef(lm_sep)) ``` or ```{r} constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE) ``` Just as with `constrain_zero`, if `constraints` is a regular expression, then the `reg_ex` argument needs to be set to `TRUE`. This constraint matrix can then be fed into `Wald_test()`: ```{r} C_sep <- constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE) Wald_test(lm_sep, constraints = C_sep, vcov = V_sep) ``` or equivalently: ```{r} Wald_test(lm_sep, constraints = constrain_equal(1:3), vcov = V_sep) ``` Note that these test results are exactly equal to the tests based on `lm_trt` with `constrain_zero()`. They're algebraically equivalent---just different ways of parameterizing the same model and constraints. # Testing an interaction Let's now consider how these functions can be applied in a more complex model. Suppose that we are interested in understanding whether the effect of being in a small class is consistent across schools in different areas, where areas are categorized as urban, suburban, or rural. To answer this question, we need to test for an interaction between urbanicity and treatment condition. One estimating equation that would let us examine this question is: $$ \begin{aligned} \left(\text{Math}\right)_{ij} &= \beta_0 + \beta_1 \left(\text{suburban}\right)_{ij} + \beta_2 \left(\text{rural}\right)_{ij} \\ & \quad + \beta_3 \left(\text{small}\right)_{ij} + \beta_4 \left(\text{aide}\right)_{ij} \\ & \quad\quad + \beta_5 \left(\text{small}\right)(\text{suburban})_{ij} + \beta_6 \left(\text{aide}\right)(\text{suburban})_{ij} \\ & \quad\quad\quad + \beta_{7} \left(\text{small}\right)(\text{rural})_{ij} + \beta_{8} \left(\text{aide}\right)(\text{rural})_{ij} \\ & \quad\quad\quad\quad + \mathbf{x}_{ij} \boldsymbol\gamma + e_{ij}, \end{aligned} $$ where $\mathbf{x}_{ij}$ is a row vector of student characteristics, included just to make the regression look fancier. In this specification, $\beta_3$ and $\beta_4$ represent the effects of being in a small class or aide class, compared to being in a regular class, but _only for the reference level of urbanicity_---in this case, urban schools. The coefficients $\beta_5, \beta_6, \beta_7, \beta_8$ all represent _interactions_ between treatment condition and urbanicity. Here's the model, estimated in R: ```{r} lm_urbanicity <- lm(math1 ~ schoolk * stark + gender + ethnicity + lunchk, data = STAR) V_urbanicity <- vcovCR(lm_urbanicity, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_urbanicity, vcov = V_urbanicity) ``` With this specification, there are several different null hypotheses that we might want to test. For one, perhaps we want to see if there is _any_ variation in treatment effects across different levels of urbanicity. This can be expressed in the null hypothesis that all four interaction terms are zero, or $H_{0A}: \beta_5 = \beta_6 = \beta_7 = \beta_8 = 0$. With Wald test: ```{r} Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity) ``` Another possibility is that we might want to focus on variation in the effect of being in a small class or regular class, while ignoring whatever is going on in the aide class condition. Here, the null hypothesis would be simply $H_{0B}: \beta_5 = \beta_6 = 0$, tested as: ```{r} Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE), vcov = V_urbanicity) ``` ## Lists of constraints In models like the urbanicity-by-treatment interaction specification, we may need to run multiple tests on the same estimating equation. This can be accomplished with `Wald_test` by providing a _list_ of constraints to the `constraints` argument. For example, we could test the hypotheses described above by creating a list of several constraint matrices and then passing it to `Wald_test`: ```{r} C_list <- list( `Any interaction` = constrain_zero("schoolk.+:stark", coef(lm_urbanicity), reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", coef(lm_urbanicity), reg_ex = TRUE) ) Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity) ``` Setting the option `tidy = TRUE` will arrange the output of all the tests into a single data frame: ```{r} Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity, tidy = TRUE) ``` The list of constraints can also be created inside `Wald_test`, so that the `coefs` argument can be omitted from `constrain_zero()`: ```{r} Wald_test( lm_urbanicity, constraints = list( `Any interaction` = constrain_zero("schoolk.+:stark", reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE) ), vcov = V_urbanicity, tidy = TRUE ) ``` # Pairwise t-tests The `clubSandwich` package also provides a further convenience function, `constrain_pairwise()` that can be used in combination with `Wald_test()` to conduct pairwise comparisons among a set of regression coefficients. This function differs from the other two `constrain_*()` functions because it returns a _list_ of constraint matrices, each of which corresponds to a single linear combination of covariates. Specifically, the `constrain_pairwise()` function provides a list of constraints that represent the differences between every possible pair among a specified set of coefficients. The syntax is very similar to the other `constrain_*()` functions. To demonstrate, consider the separate-intercepts specification of the simpler regression model: ```{r} coef_test(lm_sep, vcov = V_sep) ``` This specification is nice because it lets us simply read off the average outcomes for each group. However, we will naturally also want to know about whether there are differences between the groups, so we'll want to compare the small-class condition to the regular-size class condition, the aide condition to the regular-size class condition, and the small-class condition to the aide condition. Thus, we'll want comparisons among all three coefficients: ```{r} C_pairs <- constrain_pairwise(1:3, coefs = coef(lm_sep)) C_pairs ``` Feeding these constraints into `Wald_test()` gives us significance tests for each pair: ```{r} Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE) ``` The first two of these tests are equivalent to the tests of the treatment effect coefficients in the other parameterization of the model. Indeed, the denominator degrees of freedom are identical to the results of `coef_test(lm_trt, vcov = V_trt)`; the `Fstat`s here are equal to the squared t-statistics from the first model: ```{r} t_stats <- coef_test(lm_trt, vcov = V_trt)$tstat[2:3] F_stats <- Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE)$Fstat[1:2] all.equal(t_stats^2, F_stats) ``` It is important to note that the p-values from the pairwise comparisons are _not_ corrected for multiplicity.[^multiplicity] For now, please correct-your-own using `p.adjust()` or your preferred method. [^multiplicity]: Options to include multiplicity corrections (Bonferroni, Holm, Benjamini-Hochberg, etc.) might be included in a [future release](https://github.com/jepusto/clubSandwich/issues/33). Reach out if this is of interest to you. Pairwise comparisons might also be of use in the model with treatment-by-urbanicity interactions. Here's the model results again: ```{r} coef_test(lm_urbanicity, vcov = V_urbanicity) ``` Suppose that we are interested in the effect of small versus regular size classes, and in particular whether this effect varies across schools in different areas. The coefficients on `schoolksuburban:starksmall` and `schoolkrural:starksmall` already give us the differences in treatment effects between suburban schools versus urban schools and between rural schools versus urban schools. The difference between these coefficients gives us the difference in treatment effects between suburban schools and rural schools. We can look at all three of these contrasts using `constrain_pairwise()` by setting the option `with_zero = TRUE`: ```{r} Wald_test(lm_urbanicity, constraints = constrain_pairwise(":starksmall", reg_ex = TRUE, with_zero = TRUE), vcov = V_urbanicity, tidy = TRUE) ``` Again, the results of the first two tests are identical to the t-tests reported in `coef_test()`. # Remark All of the preceding examples were based on ordinary linear regression models with clustered standard errors. However, `Wald_test()` and its helper functions all work identically for all of the other models with supporting `clubSandwich` methods, including `nlme::lme()`, `nlme::gls()`, `lme4::lmer()`, `rma.uni()`, `rma.mv()`, and `robu()`, among others. # References clubSandwich/vignettes/bibliography.bib0000644000176200001440000000251214630154052020021 0ustar liggesusers@article{Angrist2009effects, author = {Angrist, Joshua and Lavy, Victor}, title = {The effects of high stakes high school achievement awards: Evidence from a randomized trial}, journal = {American Economic Review}, volume = {99}, number = {4}, year = {2009}, pages = {1384--1414}, doi = {10.1257/aer.99.4.1384}, url = {https://www.aeaweb.org/articles?id=10.1257/aer.99.4.1384} } @article{tipton2015small, title = {Small-sample adjustments for tests of moderators and model fit using robust variance estimation in meta-regression}, volume = {40}, url = {http://journals.sagepub.com/doi/10.3102/1076998615606099}, doi = {10.3102/1076998615606099}, number = {6}, journal = {Journal of Educational and Behavioral Statistics}, author = {Tipton, Elizabeth and Pustejovsky, James E.}, year = {2015}, pages = {604--634}, } @article{pustejovsky2018small, title = {Small-{Sample} {Methods} for {Cluster}-{Robust} {Variance} {Estimation} and {Hypothesis} {Testing} in {Fixed} {Effects} {Models}}, volume = {36}, url = {https://www.tandfonline.com/doi/full/10.1080/07350015.2016.1247004}, doi = {10.1080/07350015.2016.1247004}, number = {4}, journal = {Journal of Business \& Economic Statistics}, author = {Pustejovsky, James E. and Tipton, Elizabeth}, year = {2018}, pages = {672--683}, } clubSandwich/vignettes/panel-data-CRVE.Rmd0000644000176200001440000003660414630154052020110 0ustar liggesusers--- title: "Cluster-robust standard errors and hypothesis tests in panel data models" author: "James E. Pustejovsky" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Cluster-robust standard errors and hypothesis tests in panel data models} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- The importance of using cluster-robust variance estimators (i.e., "clustered standard errors") in panel models is now widely recognized. Less widely recognized is the fact that standard methods for constructing hypothesis tests and confidence intervals based on CRVE can perform quite poorly in when based on a limited number of independent clusters. Furthermore, it can be difficult to determine what counts as a large-enough sample to trust standard CRVE methods, because the finite-sample behavior of the variance estimators and test statistics depends on the configuration of the covariates, not just the total number of clusters. One solution to this problem is to use bias-reduced linearization (BRL), which was proposed by Bell and McCaffrey (2002) and has recently begun to receive attention in the econometrics literature (e.g., Cameron & Miller, 2015; Imbens & Kolesar, 2015). The idea of BRL is to correct the bias of standard CRVE based on a working model, and then to use a degrees-of-freedom correction for Wald tests based on the bias-reduced CRVE. That may seem silly (after all, the whole point of CRVE is to avoid making distributional assumptions about the errors in your model), but it turns out that the correction can help quite a bit, even when the working model is wrong. The degrees-of-freedom correction is based on a standard Satterthwaite-type approximation, and also relies on the working model. A problem with Bell and McCaffrey's original formulation of BRL is that it does not work in some very common models for panel data, such as state-by-year panels that include fixed effects for each state and each year (Angrist and Pischke, 2009, point out this issue in their chapter on "non-standard standard error issues"; see also Young, 2016). However, Pustejovsky and Tipton (2016) proposed a generalization of BRL that works even in models with arbitrary sets of fixed effects, and this generalization is implemented in `clubSandwich` as CRVE type `CR2`. The package also implements small-sample corrections for multiple-constraint hypothesis tests based on an approximation proposed by Pustejovsky and Tipton (2016). For one-parameter constraints, the test reduces to a t-test with Satterthwaite degrees of freedom, and so it is a natural extension of BRL. The following example demonstrates how to use `clubSandwich` to do cluster-robust inference for a state-by-year panel model with fixed effects in both dimensions, clustering by states. ## Effects of changing the minimum legal drinking age Carpenter and Dobkin (2011) analyzed the effects of changes in the minimum legal drinking age on rates of motor vehicle fatalities among 18-20 year olds, using state-level panel data from the National Highway Traffic Administration's Fatal Accident Reporting System. In their new textbook, Angrist and Pischke (2014) developed a stylized example based on Carpenter and Dobkin's work. The following example uses Angrist and Pischke's data and follows their analysis because their data are [easily available](https://www.masteringmetrics.com/resources/). The outcome is the incidence of deaths in motor vehicle crashes among 18-20 year-olds (per 100,000 residents), for each state plus the District of Columbia, over the period 1970 to 1983. There were several changes in the minimum legal drinking age during this time period, with variability in the timing of changes across states. Angrist and Pischke (following Carpenter and Dobkin) use a difference-in-differences strategy to estimate the effects of lowering the minimum legal drinking age from 21 to 18. Their specification is $$y_{it} = \alpha_i + \beta_t + \gamma b_{it} + \delta d_{it} + \epsilon_{it},$$ for $i$ = 1,...,51 and $t$ = 1970,...,1983. In this model, $\alpha_i$ is a state-specific fixed effect, $\beta_t$ is a year-specific fixed effect, $b_{it}$ is the current rate of beer taxation in state $i$ in year $t$, $d_{it}$ is the proportion of 18-20 year-olds in state $i$ in year $t$ who are legally allowed to drink, and $\delta$ captures the effect of shifting the minimum legal drinking age from 21 to 18. Following Angrist and Pischke's analysis, we estimate this model both by (unweighted) OLS and by weighted least squares with weights corresponding to population size in a given state and year. We also demonstrate random effects estimation and implement a cluster-robust Hausman specification test. ## Unweighted OLS The following code does some simple data-munging and the estimates the model by OLS: ```{r, message = FALSE, warning = FALSE} library(clubSandwich) data(MortalityRates) # subset for deaths in motor vehicle accidents, 1970-1983 MV_deaths <- subset(MortalityRates, cause=="Motor Vehicle" & year <= 1983 & !is.na(beertaxa)) # fit by OLS lm_unweighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), data = MV_deaths) ``` The `coef_test` function from `clubSandwich` can then be used to test the hypothesis that changing the minimum legal drinking age has no effect on motor vehicle deaths in this cohort (i.e., $H_0: \delta = 0$). The usual way to test this is to cluster the standard errors by state, calculate the robust Wald statistic, and compare that to a standard normal reference distribution. The code and results are as follows: ```{r} coef_test(lm_unweighted, vcov = "CR1", cluster = MV_deaths$state, test = "naive-t")[1:2,] ``` A better approach would be to use the generalized, bias-reduced linearization CRVE, together with Satterthwaite degrees of freedom. In the `clubSandwich` package, the BRL adjustment is called "CR2" because it is directly analogous to the HC2 correction used in heteroskedasticity-robust variance estimation. When applied to an OLS model estimated by `lm`, the default working model is an identity matrix, which amounts to the "working" assumption that the errors are all uncorrelated and homoskedastic. Here's how to apply this approach in the example: ```{r} coef_test(lm_unweighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")[1:2,] ``` The Satterthwaite degrees of freedom are different for each coefficient in the model, and so the `coef_test` function reports them right alongside the standard error. For the effect of legal drinking age, the degrees of freedom are about half of what might be expected, given that there are 51 clusters. The p-value for the CR2+Satterthwaite test is about twice as large as the p-value based on the standard Wald test, although the coefficient is still statistically significant at conventional levels. Note, however, that the degrees of freedom on the beer taxation rate are considerably smaller because there are only a few states with substantial variability in taxation rates over time. ```{r, echo = FALSE, results = "asis"} plm_available <- requireNamespace("plm", quietly = TRUE) if (!plm_available) cat("## Building the remainder of the vignette requires the plm package. Please install it. {-}") ``` ## Unweighted "within" estimation The `plm` package in R provides another way to estimate the same model. It is convenient because it absorbs the state and year fixed effects before estimating the effect of `legal`. The `clubSandwich` package works with fitted `plm` models too: ```{r, message = FALSE, eval = plm_available} library(plm) plm_unweighted <- plm(mrate ~ legal + beertaxa, data = MV_deaths, effect = "twoways", index = c("state","year")) coef_test(plm_unweighted, vcov = "CR1", cluster = "individual", test = "naive-t") coef_test(plm_unweighted, vcov = "CR2", cluster = "individual", test = "Satterthwaite") ``` ## Population-weighted estimation The difference between the standard method and the new method are not terribly exciting in the above example. However, things change quite a bit if the model is estimated using population weights. We go back to fitting in `lm` with dummies for all the fixed effects because `plm` does not handle weighted least squares. ```{r} lm_weighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), weights = pop, data = MV_deaths) coef_test(lm_weighted, vcov = "CR1", cluster = MV_deaths$state, test = "naive-t")[1:2,] coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")[1:2,] ``` Using population weights slightly reduces the point estimate of the effect, while also slightly increasing its precision. If you were following the standard approach, you would probably be happy with the weighted estimates and wouldn't think about it any further. However, using the CR2 variance estimator and Satterthwaite correction produces a p-value that is an order of magnitude larger (though still significant at the conventional 5% level). The degrees of freedom are just `r round(coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")["legal","df_Satt"], 1)`---drastically smaller than would be expected based on the number of clusters. Even with weights, the `coef_test` function uses an "independent, homoskedastic" working model as a default for `lm` objects. In the present example, the outcome is a standardized rate and so a better assumption might be that the error variances are inversely proportional to population size. The following code uses this alternate working model: ```{r} coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, target = 1 / MV_deaths$pop, test = "Satterthwaite")[1:2,] ``` The new working model leads to slightly smaller standard errors and a couple of additional degrees of freedom, though they remain in small-sample territory. ## Random effects estimation If the unobserved effects $\alpha_1,...,\alpha_{51}$ are uncorrelated with the regressors, then a more efficient way to estimate $\gamma,\delta$ is by weighted least squares, with weights based on a random effects model. We still treat the year effects as fixed. ```{r, eval = plm_available} plm_random <- plm(mrate ~ 0 + legal + beertaxa + year, data = MV_deaths, effect = "individual", index = c("state","year"), model = "random") coef_test(plm_random, vcov = "CR1", test = "naive-t")[1:2,] coef_test(plm_random, vcov = "CR2", test = "Satterthwaite")[1:2,] ``` With random effects estimation, the effect of legal drinking age is smaller by about 1 death per 100,000. As a procedural aside, note that `coef_test` infers that `state` is the clustering variable because the call to plm includes only one type of effects (random state effects). ## Robust Hausman test CRVE is also used in specification tests, as in the artificial Hausman-type test for endogeneity of unobserved effects (Arellano, 1993). As noted above, random effects estimation is more efficient than fixed effects estimation, but requires the assumption that the unobserved effects are uncorrelated with the regressors. However, if the unobserved effects covary with $\mathbf{b}_i, \mathbf{d}_i$, then the random-effects estimator will be biased. We can test for whether endogeneity is a problem by including group-centered covariates as additional regressors. Let $\tilde{d}_{it} = d_{it} - \frac{1}{T}\sum_t d_{it}$, with $\tilde{b}_{it}$ defined analogously. Now estimate the regression $$y_{it} = \beta_t + \gamma_1 b_{it} + \gamma_2 \tilde{b}_{it} + \delta_1 d_{it} + \delta_2 \tilde{d}_{it} + \epsilon_{it},$$ which does not include state fixed effects. The parameters $\gamma_2,\delta_2$ represent the differences between the within-groups and between-groups estimands of $\gamma_1, \delta_1$. If these are both zero, then the random effects estimator is unbiased. Thus, the joint test for $H_0: \gamma_2 = \delta_2 = 0$ amounts to a test for exogeneity of the unobserved effects. For efficiency, we estimate this specification using weighted least squares (although OLS would be valid too): ```{r, eval = plm_available} MV_deaths <- within(MV_deaths, { legal_cent <- legal - tapply(legal, state, mean)[factor(state)] beer_cent <- beertaxa - tapply(beertaxa, state, mean)[factor(state)] }) plm_Hausman <- plm(mrate ~ 0 + legal + beertaxa + legal_cent + beer_cent + factor(year), data = MV_deaths, effect = "individual", index = c("state","year"), model = "random") coef_test(plm_Hausman, vcov = "CR2", test = "Satterthwaite")[1:4,] ``` To conduct a joint test on the centered covariates, we can use the `Wald_test` function. The usual way to test this hypothesis would be to use the `CR1` variance estimator to calculate the robust Wald statistic, then use a $\chi^2_2$ reference distribution (or equivalently, compare a re-scaled Wald statistic to an $F(2,\infty)$ distribution). The `Wald_test` function reports the latter version: ```{r, eval = plm_available} Wald_test(plm_Hausman, constraints = constrain_zero(c("legal_cent","beer_cent")), vcov = "CR1", test = "chi-sq") ``` The test is just shy of significance at the 5% level. If we instead use the `CR2` variance estimator and our newly proposed approximate F-test (which is the default in `Wald_test`), then we get: ```{r, eval = plm_available} Wald_test(plm_Hausman, constraints = constrain_zero(c("legal_cent","beer_cent")), vcov = "CR2") ``` The low degrees of freedom of the test indicate that we're definitely in small-sample territory and should not trust the asymptotic $\chi^2$ approximation. ## References Angrist, J. D., & Pischke, J. (2009). _Mostly harmless econometrics: An empiricist’s companion_. Princeton, NJ: Princeton University Press. Angrist, J. D., and Pischke, J. S. (2014). _Mastering'metrics: the path from cause to effect_. Princeton, NJ: Princeton University Press. Arellano, M. (1993). On the testing of correlated effects with panel data. Journal of Econometrics, 59(1-2), 87-97. doi: [10.1016/0304-4076(93)90040-C](https://www.sciencedirect.com/science/article/pii/030440769390040C) Bell, R. M., & McCaffrey, D. F. (2002). Bias reduction in standard errors for linear regression with multi-stage samples. _Survey Methodology, 28_(2), 169-181. Cameron, A. C., & Miller, D. L. (2015). A practitioner’s guide to cluster-robust inference. URL: https://cameron.econ.ucdavis.edu/research/Cameron_Miller_JHR_2015_February.pdf Carpenter, C., & Dobkin, C. (2011). The minimum legal drinking age and public health. _Journal of Economic Perspectives, 25_(2), 133-156. doi: [10.1257/jep.25.2.133](https://doi.org/10.1257/jep.25.2.133) Imbens, G. W., & Kolesar, M. (2015). Robust standard errors in small samples: Some practical advice. URL: https://doi.org/10.1162/REST_a_00552 Pustejovsky, J. E. & Tipton, E. (2016). Small sample methods for cluster-robust variance estimation and hypothesis testing in fixed effects models. arXiv: [1601.01981](https://arxiv.org/abs/1601.01981) [stat.ME] Young, A. (2016). Improved, nearly exact, statistical inference with robust and clustered covariance matrices using effective degrees of freedom corrections. clubSandwich/vignettes/meta-analysis-with-CRVE.Rmd0000644000176200001440000001556514630154052021625 0ustar liggesusers--- title: "Meta-analysis with cluster-robust variance estimation" author: "James E. Pustejovsky" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Meta-analysis with cluster-robust variance estimation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, echo = FALSE, results = "asis", message = FALSE, warning = FALSE} robu_available <- requireNamespace("robumeta", quietly = TRUE) meta_available <- requireNamespace("metafor", quietly = TRUE) knitr::opts_chunk$set(eval = robu_available & meta_available) if (!robu_available) cat("## Building this vignette requires the robumeta package. Please install it. {-} \n") if (!meta_available) cat("## Building this vignette requires the metafor package. Please install it. {-} \n") ``` This vignette demonstrates how to use the `clubSandwich` package to conduct a meta-analysis of dependent effect sizes with robust variance estimation. Tests of meta-regression coefficients and F-tests of multiple-coefficient hypotheses are calculated using small-sample corrections proposed by Tipton (2015) and Tipton and Pustejovsky (2015). The example uses a dataset of effect sizes from a Campbell Collaboration systematic review of dropout prevention programs, conducted by Sandra Jo Wilson and colleagues (2011). The original analysis included a meta-regression with covariates that capture methodological, participant, and program characteristics. The regression specification used here is similar to Model III from Wilson et al. (2011), but treats the `evaluator_independence` and `implementation_quality` variables as categorical rather than interval-level. Also, the original analysis clustered at the level of the sample (some studies reported results from multiple samples), whereas here we cluster at the study level. The meta-regression can be fit in several different ways. We first demonstrate using the `robumeta` package (Fisher & Tipton, 2015) and then using the `metafor` package (Viechtbauer, 2010). ## robumeta model ```{r, include=FALSE} options(width = 100) ``` ```{r, message = FALSE} library(clubSandwich) library(robumeta) data(dropoutPrevention) # clean formatting names(dropoutPrevention)[7:8] <- c("eval","implement") levels(dropoutPrevention$eval) <- c("independent","indirect","planning","delivery") levels(dropoutPrevention$implement) <- c("low","medium","high") levels(dropoutPrevention$program_site) <- c("community","mixed","classroom","school") levels(dropoutPrevention$study_design) <- c("matched","unmatched","RCT") levels(dropoutPrevention$adjusted) <- c("no","yes") m3_robu <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs, data = dropoutPrevention, studynum = studyID, var.eff.size = varLOR, modelweights = "HIER") print(m3_robu) ``` Note that `robumeta` produces small-sample corrected standard errors and t-tests, and so there is no need to repeat those calculations with `clubSandwich`. The `eval` variable has four levels, and it might be of interest to test whether the average program effects differ by the degree of evaluator independence. The null hypothesis in this case is that the 10th, 11th, and 12th regression coefficients are all equal to zero. A small-sample adjusted F-test for this hypothesis can be obtained as follows. The `vcov = "CR2"` option means that the standard errors will be corrected using the bias-reduced linearization estimator described in Tipton and Pustejovsky (2015). ```{r} Wald_test(m3_robu, constraints = constrain_zero(10:12), vcov = "CR2") ``` By default, the `Wald_test` function provides an F-type test with degrees of freedom estimated using the approximate Hotelling's $T^2_Z$ method. The test has less than 17 degrees of freedom, even though there are 152 independent studies in the data, and has a p-value that is not quite significant at conventional levels. The low degrees of freedom are a consequence of the fact that one of the levels of `evaluator independence` has only a few effect sizes in it: ```{r} table(dropoutPrevention$eval) ``` ## metafor model `clubSandwich` also works with models fit using the `metafor` package. Here we re-fit the same regression specification, but use REML to estimate the variance components (`robumeta` uses a method-of-moments estimator), as well as a somewhat different weighting scheme than that used in `robumeta`. ```{r, message = FALSE} library(metafor) m3_metafor <- rma.mv(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs, V = varLOR, random = list(~ 1 | studyID, ~ 1 | studySample), data = dropoutPrevention) summary(m3_metafor) ``` `metafor` produces model-based standard errors, t-tests, and confidence intervals. The `coef_test` function from `clubSandwich` will calculate robust standard errors and robust t-tests for each of the coefficients: ```{r} coef_test(m3_metafor, vcov = "CR2") ``` Note that `coef_test` assumed that it should cluster based on `studyID`, which is the outer-most random effect in the metafor model. This can be specified explicitly by including the option `cluster = dropoutPrevention$studyID` in the call. The F-test for degree of evaluator independence uses the same syntax as before: ```{r} Wald_test(m3_metafor, constraints = constrain_zero(10:12), vcov = "CR2") ``` Despite some differences in weighting schemes, the p-value is very close to the result obtained using `robumeta`. ## References Fisher, Z., & Tipton, E. (2015). robumeta: An R-package for robust variance estimation in meta-analysis. [arXiv:1503.02220](https://arxiv.org/abs/1503.02220) Tipton, E. (2015). Small sample adjustments for robust variance estimation with meta-regression. _Psychological Methods, 20_(3), 375-393. https://doi.org/10.1037/met0000011 Tipton, E., & Pustejovsky, J. E. (2015). Small-sample adjustments for tests of moderators and model fit using robust variance estimation in meta-regression. _Journal of Educational and Behavioral Statistics, 40_(6), 604-634. https://doi.org/10.3102/1076998615606099 Viechtbauer, W. (2010). Conducting meta-analyses in R with the metafor package. _Journal of Statistical Software, 36_(3), 1-48. URL: https://doi.org/10.18637/jss.v036.i03 Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: Effects on school completion and dropout Among school-aged children and youth: A systematic review. _Campbell Systematic Reviews, 7_(1), 1-61. https://doi.org/10.4073/csr.2011.8 clubSandwich/vignettes/apa.csl0000644000176200001440000021415314630154052016142 0ustar liggesusers clubSandwich/data/0000755000176200001440000000000014630154051013570 5ustar liggesusersclubSandwich/data/SATcoaching.RData0000644000176200001440000000302414630154051016627 0ustar liggesusersý7zXZi"Þ6!ÏXÌàØ])TW"änRÊŸ’Øây°­à,øeY“¸ÚlD« Ý‹oÍ/APÞÉ®yµ½Z‡À0Ƚd—¨º:#BÚM…k±|Ièfô:Òöæ#ή+´˜¸ø¥;wÖ É7•ê””Þðû·Òý%ÎZ+ŠŽ&ï<Óg´ñ i·J3ÒŠÖXÁLÚ&š}f¯©©ô^²æ6&96Rë:˜kózFNB=å:\1’¾ð¸N?äÒ×±m‡$ç\K¬K³›Ð¢€„˜©±õ+6Áÿ3V¾‡_ÂÜN{þ²À?bã„Óîk»7‰ÓpÀ´Ó6*ëóôÀË ì+ãiÌa¢÷SVl øJ”³#™ÆÓ4ã›N¡<󥄓™Î9’Ù9a®õ •`ß•Œ+´ˆÀõµ ýÏø‰4ŒX$’_m[U Z­L¸B©"ÂôVOïüDÎtºAcf‘ïò~µ×Y/©–ž“ú˜ÎR³îwê|q$‘“q7ÿ›÷?õ¸ÞªÎ}QòÒùž`>Ê–ñ,1°¸zЮ–ZÒ~lŽq.´-C7,õ*…0OÊ”Éa|”Þ,ÕøŸ³f•tÝÉ`ªmqo:¸aóPhI½>ŒìØ_d!ˆS¹ý¤H?˜QÝÏ&ïú'êuBªÔ3×Z!‰ŒÊ•BøJFöç0|#¤4x ¾„À›êËYÛwò¯† e8$úÀ›Ïí×õö^j˜?„æ³ÞÁV÷ûX±ùk(,læ³}ÐÏ2Ë0hh:ÕYüSÇ3Æ«[¸²ÕFîCSá4€¸}«CS9ýûIŽÌÔnr’‹:nõÊÛà;‡eÈYî2zÁÚƒ’^ÊÙ\,’–;öpiu*õœ[Ç/ÍÕ(—ð³Öý§“¥l'—Âe¤q¾l©xƒ|Úbz_Ž-s Tí½Ë|,žì7mf§*^Yµj‘dÎMÚÓcÑ”ï"Ú¤*»í]Ô ϬjBÞè¯ÜîPç_Jã‚w`û@7ü€ð…ý1èè¶,2Ô3°QU–ëé­vc­R§¾a¯ën˜â•«>Þ,BvåÅÒÿá_+T/™øú ðÙ#,/«T”XnR?K—^wÊšƒ `8‹€œÏ É[çÐ2ÁRU‰MÅŒ9àƒ¥(»Ö¼¨s…³3ióõ¯jï¡PÞÆ i¢ÞÎ\ÞCø\ëÆåKŸ_ gƒl: „ýðì¥*úÜ×wÇ×]ùƒ#ñqY¥G(•CËÈlg~tüPሥqÕ㮞;[Ö¹<ë‘ÿ¸MËoèV²´d$ç܃² Zõu.1–j…hmŒ7ÃW{ë¤Óš¯°ÊÅi…ö ³R’Ë^ly»ë¢j#yx7k„†BÁöøþ¨Î‰´þ |*c:µ–FfÖ SÉÃ\4wÙ¹ 9¸\‡¶gÞS<ŒÉÜËY¢oß,¼ß=^X‚ÉK‰¦:-€»*FrY&ʱ­4?¦Äý0X—3Lðþ§î¦wóÓÿFÞ¥<#ÝSÿùó¿‚TŽÖÔŠÁÓ£wSpë ½šW§yiG¹Ñ…°B¦¹8‰D&ºU†0¬ØÚ£²íR®f´{KÓ˜Ùì¸Þ•*Áæ­?è éEóË>po²!ýIë–§²f˜žíÁœbJ™1™}O]—\>SiøŽF#.ž‹þ' ù¤ô¬‰ùÐЮDÌÎCßP.Èûå2ëVˆ‘.ç„®ÊNÏ\Ѱ,Îaþ¯ðt3»?A¹:â!66n uÈŽP3£û‡VÖæˆ~8v¼!Þ-‰¨>²Ú7kj‡ìpÏoÚ‡j* >m:ú»XÜ@=*wxð#K\ mµe^ëéúSŽ)•¹Õ—YC‰¨´¢÷c“¯Œ‰«¢4ìþ€€n1F“oÑ>ó&q‚p?ûG†Çsn— ˆªw€êŒ¬&fˆÈ\Ð劮촾Ü5ªâ”ð ƒ:F…w>0 ‹YZclubSandwich/data/dropoutPrevention.RData0000644000176200001440000004032414630154051020256 0ustar liggesusersý7zXZi"Þ6!ÏXÌ༺@—])TW"änRÊŸ’Øá푼’ÝJ ˜ šzE‹#w9BÌ™¦n'¤y.°Ç;oï(±­â/µð~œÂ5(G)Éx oæ+ݬ2§TÕi3ú¯ò~/?ýü+Ù=‘ ¿Q®Sns’œzòÄž[ç ê¦DkÝ@¬Y‰8ÍUµ ]R­E7 îTÀ–ÉN¦N ôG'Í( † FH†¾Õ‹g(0)ëSTÆ™qº¥­ü~kŸ^è´Aaß÷cýÃx°wêX|žfMd$¿äw+]ÀhšƒxãÞf?Ǩ1V$¯Û(µªü¤LNò¡3p*¿¦p”æ$Xñqˆð\?î e|@¤Â’ áÏëan|OÈñ÷!ô*ÀôEèÐ VžèhÂÆ;°_9œʉ‹Â¤á&õUí‘j³+¯3dú&eüìHžµowÒÛqÃf4 k¸—·óøÈåß„¢ø¶ß’»H|)4[q½zÅa[£qÓ!ŠwhìZý-˜Ð“–q™39ƒ<ÄY…¢¯8&A¹jÆ¿¬ðX-âªã¦ž|MC0­Ư9g®í`Ÿ½'iê¾ÏA‰ŒJTíùVÊÀjVBüý¾y æð3ؘN/õLºË·‹€œÀ+‘Ë0²> m¦i¢>ÉÞ~÷·ªá0¡@ܳJ²¢ÑªÓé³·EYC\Ó-°7B"D\pËP)—Ö+4çbšïs¨´¶Z”¤c­\{Îày¨¸Ð±ÞB ®æ”hT¶t‡ Aµ<×t×õ¼Z÷è@ÕÑV”"Æ£ç8¡oײ!K*8Í·(·Š¸oí9 À½v 'E2X4«qÈm^VT\‚}#6†ÅsîþQêuaN™`mèÑëJÆ$м‹V¼"q̉½˜™òs]Z¾­@_ÃkeȽl2î#´+;*™ÄéUëÙ”Òó®ZU6íó$¼«¾e$íz»ßŽý˜êïæ† Á|£_¼Ý¼m$äþ{úªS9Ç(ÓßúÄwÌÑæÚæ2‰ú€iæMkâKØ5Tz‰ª*ö ¦›´ |¹Ð‰,ÍuÆžÔ¼nÕŽ¼û»ÏÀy4$Ö˜wÜd`ãýAž‡})åØK4Z3HA«KGJ¨OŽÆ*uÉ% ËpÉݸ×îí0ébµÿ%<‹²SB¬c©aˆïÑÐëþ%¾Ìo2n2€, ¡<U<ÁµÀ¹¶ªMH§E›±•>k=£¤K©6?Î+ÚPížâ´Õ­$&æ\SJ^DÏ …­ÑÙîK 9±}_álÜÁT6ŽßA»)Û"ô—ɱXO<ŒD]…[O6äe¨­¥#Lô: ÖCÕöÏÛˆ´W••¤Þ>d7ÈO/Î\Ô}fÚ÷¯>?gÉÚëÁ¸£AM4ˆt¹–mëû9r.¬¹J§z9âùÔ¨ —Û<ªƒ½µa_ÿßÛë'G†\QhÕøÑ­ »¹‡úÏ­Ä~E=·/„¶Ç .\¨®ˆèž¿’œXêÑ<'i{ÕàØ»áu®¢Wq=I_R’6YT9 èð-zAþü¶–˜;g?KÃ,µE«ÿû}ãž;eí TƦt;é¶fÂKÚ?ñ(ZÅg½(Óñ-^/€¬®Æqè>ÕÛbÓLÔ~=3íœ|)¹$†ùe){‰ž'åКR`ç}T¢ÙÙx–_<^ë>ª`½Ùòq“u ê%JЇ¤ú­Û Ñ Ä‹K‹ÿhc;ÒñÓ{·è³z¦ß,Y97¨þ!ƒÜÁ݆î$A-œ‰eȸòn3 å¨â»ý2CÏ÷GÂÆ:5¿®]Þû)eÂáÕh™ü¼5à_¼å6,³­kš*aÖÛÕ–È}ž¯JœMU&™˜ׂY ¹&ëÔ»óO:¡?„2ƒíQ€JQåá e}\4çû,6ˆw‚ä8,uvë»I‰ׂ±²(1± né!"ª«€¹ý= }²£½\îüyÌÀr±ôÚ‘)Ñ1'[ u\B²·q_Áט‹¥ˆ4­uÎb‡ch”÷œŸ‰QD¨bneÕCk.ˆÆ­\ýëC <¡— ײj‰œb¿~f¿X=(RÝL0³Ò‡›7ÞîýGD}ô1yY·Å餱Š| ³k •_¢‘âÕ„d¯žöo‰?.nßï)†$.ÍþRS1m÷¸ñ»°p|DµÃ(Iî¼;YõÙÒw—¤‰æ«Õ{ȹR"gOü_îvÅ_»zÐ:i›Ÿ=—Y=2Ä‹Â0þZ2½A¹¤®Æ¼@m¹eê“H öYû98…¹2§[ö³§ðvZ5S…‘¹\«;Ø«ÜÿâÙXé¦5DY§-ÚÌ—¡8KB‰!*û6JJÜF‡ìï-ÑZ™žžØ’’……ì²)Â'ŽÆâ  Ð=Ⲇµ°o Š¥õ Â0RÉuºÕÖÍÌÆJE²ôØ]ÛEœYã=©Úו¬i¶æ°ðá¨ÀPÅI5}‹ßÁÊè(¯ÅË­LÞ¢'½Pd€a€I©ò˜þBA¼àŒ³¥i$h †HJk s j>Ì7\Yë£ùA®ûï°ÌÔUÐ VÌ )7k1ûÝéË:9%©HZ×õéÍ"¡OgFÒC¹Þ“L8YíNI\•sŽ›bvŽÃbC|²ÝÙÚ†6°Tm5t Øó•Q¨ Ň^þuTQŸƒÓ¯ˆ°ƒ¦Q¼­Š8Fƒ´b¿,Ü19:™óz'ÈšµÓ$š,NÝüÓ­ký0ë*â<¸³•ö/äó“|à»4:ÖQ9)@Cü+{½-8H!}WU⌤Eœì—±!me“ç2b›nŒP§–*ŠuïN¼,ˆ¹a;XVŽ­*Ë?v*ú}sÁS­K7Z¦²3êª|h&÷…ƒû*5ÙÈ·8õUDqˆÉoZ›Ÿmm•§Ògðhr¥ÒÞü©j3˜‚úÑ~òg¾6á ƒ¸%ðyE1¤áàcä\KIG®ÞSèr>8!Ã÷ÍR  C‚­:/+*ÅÌCO2A?°aø¸ #G#x~òêf•Z PûÌ ]Â=+lÀÅÂFv’zûóL Ë·žvZÍçfÏt‹Žì ÇjõL›] RB5ÜsÒ0ÿd˜‡±1"´Óå^uǺ%õXÂ`­ì˜p"¿>‘`£×¹”=Ú9îe«‰t©ã¨¯PãÀXX¶ ­OG¨¯Ë]ó¾*Nƒ×¼^>CUv½¬zý3ôP¢ÈÞå¡@ÅBë\D—aõæü8\ôKU?üì1qÓ]JŠÏsI2äN.4¹õ…o0s§{o|ž¾Krê‚ÚiŽY D”ýwÁNGf•NV›i€r˜hŠá½/ɢдk-”À·+wI‰³a- ‚Ÿ» òáØïeÕ6rlÏņìÂþH¶Iô5š¤_é|ð¥Óù“=c²‹Ž-*5ÉþDOêwŒ®î°{>V×Ò½Ò©ÈÅtþýX{5šÀ²÷k^`pPYÒˆÄ޽»I¡½½ñŽÕ*_ù¬PþêœEœ£"n62­FÒÞ%ak‹œôúúÎTæšèh%/RŸ[OLqÊoŸ.a|Ìî—˜_ ã¬ÝÊs=Ÿtƪ:…&Ý¿¿«BRiKiacß×·È¢M“1¬ZqŒÁ¬–Zÿõ÷.~ýܘ0€Z\1¢sbŒw«Ù¸vý,BtJG“rgÆ%ˆ¶9æw÷µÛT¥÷7ùAü¶| æSìáÓ-’Ä „°‹Ì×ãÇ%+cú„žùèÄ[­¾Aÿû–ž®x¢§}Z˜ø£k"¤u}˜ ;€…ÈS¡Ÿ$m{D];®×âp<|­¬ò¸™/Mó¢Ž#ÊͤèÙG·X¼W7ÒJ5ƒ®µˆࡨh>Øä‚‘ëú’xLÄó…‘sнY,†äõ¡¼éªsÀŸU—û3©JZ^é/ lzbwß±Qî;ˆ5:…@’Õõø,Eò»Å”•)¤@Ф|ÜèÏñw (õ*àɆ6–•W%­æªSFÏlw9(d©õž[}‹xeFé8#QçËjN¥þ˜žXQ–½‹„àŸ¨Ìò¸¥6èO¤á—g²›ü½ulaðrKGøŽGgIà‡’æÛ·2C«Óëà Õ¬„w+P©u!TJJÚòŠûîÒ¯vzvÚß_Õ=,ö2÷3ö§ÓæÍÞ)jgVYX³ÐÙe¼DûÛ)Áá0Z…ãå¿súR¯¦Ù=Π”ÀY‡ÖH“Ü5àW!ó: iRÊÈaã‰nçLÇ’lòúYì'®ÝÿðÅÉ9PDÉ™©¥TwzY?«p~@q†m.±s+Oj¼=K.É”!0gY[‹£»·fˆÁù€”Чæ|mÅ@PYr¬¶žvQ• òJO|Rjr^fƒrñ£’.â²­’Ûgî±™üûŠ€xÖ d…´1ø'mÛ Ã"|õÑMÄ;¹Þá~nÁ£Ù+(턦- úðxjpšâ’¶•cèñ›hB|sxšøFŠ%e3rÃ^ØÜ–Jž¡­gòŠn†–-×åð—úàãFÇá¼ùݤwð3Œ ÕdŽ[îýLÒ¾T©#̸4Z%åü¸ÿÅqfÖ›1>fúlÓžßî¾'w ÷õìï¼!¿nXñÌ,"(våVgi—q±hµœj-~$ÒÚCű«je´skù£zÍ>!Ip_K!ïw0î~½u§Ùe*KG Pï%û;Õ7cñ¡¶ j¶ZÉ·ZŠ¥<Á ™­Löæï°¿´`ã‚mÂ%4~ «þ>€7ŒnÂs°_Ûñ—#QG)}åÓÁ¡×Á0ÓKƒ(£VðþuV m”"þ)pZbûöÁ£kÃ$tX½²Þ‹;3GXhŒjÎ);ÓpÂ܄¨–{Œ•0܇ª¢‹òâƒÿŸ^ᄎäN[©µARä4½½*OâTEcX‡zqýdŸBF‘GÄÅ/Èj×K­ä¢f]†H,sh ìã·‹LFUüfÚ§v¡•î®i+Õ-Æ¥§g~¤×Š>ÙÑ>šsBP­‹xë ¾|RÇ÷ ÝM\ ¼¬6•LWax°6R²˜õì²ô3†žY%­&$i ø.§È%wÉÝC#˜!å`h£©ËðƒØ:>Ešt—\rrù£VØx {sÝ}×\‰@"áçɰDfÊëÜ(s1çNP~]É '@£oÇž‘ÁU„—$ì´ïˆ¶ƒÚ¶:¥‘o/¯ 4Îq¼Ž¼Zêñÿ$­°§Óí4î_ìÑ$øëC»îžœUbÍj<;\j©YŠd “Z$ç–º§´u9¿ïo «”Ó.µ_.å&Nn=è9ÿ@”¦8ûØh2¡µçR1}/ÚpÓ­$" èƒÈV² Ë7_Êä~ߘ ³ªröÍX•*§àxAâÿ·Ö)å°7_$‹i,¹çn¼oãA¯6E×Qd!ØË”öø½žpOɧLK‘Sõô†ê„Ó#à?¤¡\§è<|ÖÈ G9­fäôùN§Ÿ&÷²c²0æSŽßÄ2¡Šìfp·¸H!5ƒ0;÷<ô™ÅÌRLØ:ÑKõâL.“þ2=¬[^˜ 1û§ÿXbNuŠ”£éðí=Õ&cRi‡T³ËögÁtõ  ™÷£F!Ä%šÌ×i¹éºð$w ÓµËfIÆu9UL°;1­b>îRs¯³YõÛþΟ}£'M&2Ör[ÛâÚ£S=qRòÙQ’àä<3¦mµ{˜A°V×û“bT¶:yæÒ…‘Ì{‚DÞÐ4?éÄ2ƒ[½ÉrKÈvqj¬á­ü;hÊS¨t¬gÐw1E‰²¶AÙA ÓävÐDNÃÞŽûYÌØ;zºÐú¯þ–s>ÚÇ"褓èâ˜*È(ÓùšT©Ö„ážÙ˾R>Ïtç=»"¶˜ÅÛsWå~ê³;³Ì åüEˆc[ðtøvå¨ñ¶v¡}¡C¿ê.!@¤1^ïM9 ‹Ç}bÞ¬™‘p!ÜËm;iÛQÒÖÝÇEÆñÉx;zÝT5B›ø6ÓŠHI®„&ôþÓ?ýõNÈý[g]¾нm§WHV·¼[+Kü§ P ö"; •2– ;âV|6ØJ-"£u(æ-˜Ý´^d›ÇÐA_ÙÔ©ª’ë™>Š¡vK¿©F)iÿwz&ë=•mÐù£pb¢B¼M¢À³ÐÝA¤»‚ýL•Ö“4nM0°ðw“Ãp‰TV¾`­Si @|4G0„U;͉ê{yt¢UÝ€¾E–IÕtÀ€Ž™l¶{€Å"U~sÿi-¸ O´×ëÔpõŒ¯A×T.¨ÈBhFs}²·A5ì<Ê™«ê#OêÊ‚œðQв&bM‘W×¾pgq &m§P‰í2qyr:ïáö—ÙòC‚ç"Î Tœ7™t^ )Ñ•]W˜¾{$óÛÓ5xU—­ò(I%Eu°f³å±R8:ˆøÑJâÖä ·¬}„1ûQêêû(¦ýÇJÎ\NDÑ­žÐj½”Ñï¸:Dìñ ï1ÿcªeõ"¶äÐn£æ°8¢Âð!ƒPo˜¥Z‘×,F%ºá™ø•·KàfÖ%YóÄJÐ9h-÷² ‡s-XØKDÁµ­]œæ› Å¡ŽEa=é/Íá˲¼Öèl4çó5þꈢõ¡ì'aÞjáãh¿¼ÐçÕºRÍÚœèà ;ؘï†ÅÚ£m_îÄyª[¶Ú*ãò·ä#JK1J@ RºÑd'²=rNè¾ae"ªçUé´©ÿRå~üîìø€>¢põggZIð¿–ë9Ú–Ÿ²û¥ÎúѶv|z]I¢a¶i/Û3þT:/~Õð[R™‹%sBe¬«—Ÿk(E-—7A?Htœ‹!þnjeÐóHÎÝš•YÕ¹;µá>œéà›œsJ6›3Åäãp'áë‰íˆŒÒ=»íCoµDhŠ}žròP~.ȧÿëJ0 ÜýÙŒõŽqõû ì:éÒ¸¨Úrh#Ñ7{E«rÔ¬Õ5„Cùã×asÙƒó ÄWú¿{òÕ_¦N¨C¶Ï¡SV_õ .­sœï3$âqï5Z—•Ym¯d*eúP-ÊlOÖëð{‹†_¢‡ýDµÙW6¢{u¬ 36A}w ”µ‘’4ª*¼´@™3yºò¡$4 .GñËþ‡Ú/³õ0Ç$0@ê0Gò(\ " £0—!íêuˆÕ^kAgºŠ×rÏ2OäÕ>Û;”6˪_J2¼j‘±ß¿ôT‹ÜáÝBÄì=±ÌK~"¦¯<ÒÔ¾œ³.êþˆ9˜•âc¥^ÍȦzF#¢‡äøMêÜ2«QÏ‚»ˆ¤Z¥2Ç®tÕ^¤ ‡ 8ɶƒ̶F÷?ËÂ3†ÇcÝüø’•8bñÜeã’ ”±lqd‹ùYŠQ¢Î±µ8ª>ÜnÂùK\Â}Þþð–„FÝ |× G§°eÆÉnúJO—ts*Q³÷#IqXl6Qø·£MÙÍFÜÛØ­U¾¦#Bˆ£XpAœÞ5u\²­¬Š6]xQRd‚r³˜ÑÙà_’ºmpÜ>Ùk{i”™µ“\’¢ùéñ¡ç½†·ˆŸûôÍQå>µëè´D‚7ÏÌ)ÌŠxPxýn…ô¥¹eì'KâôR3`˜–eÙðã©Mì’­ ~5šV«õÝ~\Q2Z¡–^ÎÁÁö,›fŠ3‰1õØœMÖ ›¡¿·‘¸¨ D¡·'ÁßÇËÿåVNšªlhRÓfÉÞ)ðÌgH`™€Ë¾_CËc ùª!œ€äØH §Òy-tfÑüx r¬†ÒõךKî$ÐŽ¼ïuƒµå:éh Óëкwçgx2rˆ²2kôã©áj;NAì([çßP·qO9Ž}Æ µ‰vþû‚7°áJ¢¢´MH'Ã#F.fùŽÈç(.Î^zY´tf`‘ñ[ØT ïïXòÛœ÷w×?Aw¯ šð˜Ì\€Ø ‰jà -ÝCs‹Šw`ç>b0sà1?(ˆ®7'ËóCÚýfàâ'Xwb®R p)"OÕ#>îf#ÿZžX‘Òb kÅß¶awµæŠä¾îÄc/×yµ‘(  VtáñÄ[E¿@Ók_Lãö`@±`$pzåãWÇ:¦9̃þòÎÕ˜ÃSE$x¨ab CÅÀºå–••[Î}‘j¯ÖÊáOƒ•šÓ ¤ y˘Øç)#é> k#Í™Lyæ>o¬ªdc=Ùr§K§Èf9diªÏ¼Å*G²¿ ?ÜXA/úb¡! žîFùJJ‡"o]Q/s'‰ô&)?üøò·{g”¼¼mØŽ]Îu'þ¶:àS>Û hjW<´²ëùti¡JḼËL¬Žcí]~ ­–j 1›ò`¬²  csÈ$¡F²ß¼ˆÈ±VÁ¼Ð\pGkß8ˆËà,Á#$Ë—,˜Ë«_È‘ð•Ö!Æ4Wyë¼»<¢ãœeû^‘Íó”ŒÆd1I½Η״41ÁB‘:pøºc ¬æÝwOZ­6¦Mæì«$7 ‘õFœ-Ü“{ËMA7åBʉrñ® í(Ø*ð#¬9Ù[ndúå“EFœ›|æT~Jjþˆ‡”¡T!#“v/¤¹È‹€_.—÷Øw·AUYEZ‹½óÛéÓq'ð€ã‡¼À"X}²wŽæh\U+èóº! Û³X6”ѽì^Õý‡]—*<¯N(1J•˜ãËf?zƒäT®³‹×3ž¬C«n_`¬Çsi³øuÿ} Š9ñTù†°·iëáO:¯è@/wÌ„ÝÙå`Ç (͇ZÎa°[2Ü3šÖ¸J+¸³/ 7Ј–ÑÑ]môûVïñ+ööÔ—‡4PˆÉüë¼–ëYÃÏjú0ìš™Í|Yߺ4=‘xªðLÆÈä¨uü¥2‹y>åO‚Oå¬ýþ*FUË~œ_Ê-¤ƒ„Õq¢‚=™Mü@^ãûX[š¨§L Î¼Ö‚ݧ—d:ÚUî] ®œ¿Þ”,[]*-_$ÿ›j³Ü ¢Ñ˜\ ¥™É2¨Æª¨oïÚ´œ!ò¾Zf©ò‘yÇÌÆ7?å»þÇ¥9¡-k ®À[‰µ¸^K·³AQîæ£efG¬ÝVí2·>?&Å#·ÿRPò¥ëßb8" ŽÏ&ÔSÓ'“­a¬Jú—D_W„‡ø'H#èà¡#ƒ¤=3A^¥pËÓ<› “@ÅéoJ˜Ù€/@¿úŽÅa­èÆ~€cÔìÓ,ûì“jɱ×N1öÈÖZ<Н1÷Ž@—[Äbž¶ÔÓGŸÍ7^Yz}@`†\}eÓÀ ¸:ž3§¿‚¸c÷vÎÑ‚"Ó¦ÀÁæ4•\Y'yÃm©ÖEÅ>{®>R€ÖÛðíÓucÁ÷¢…&Ý÷AQ[¯ÍÉw[6Ì&a’W3®¶·ü‡(¼ßÚA02PÒu/²VRëž#4¥D8)y(îtŽà°›ìÓds6Œ|×’pygJeËœ/È5û× m²«ò°È–Óî û˜¿Ý²aáÉ_*ŠL÷™á¾°ò ûó÷8°šõ¥j¹G•ÆãÍ~H]µ­· «8ãöpU˜åNJßðPä½!2þš´ÆŸBLÜ¿¼«#Vñ¢ÎŸwÝÖ·DY^m ¢¦ë›dsAvQ¦ô?è¶’¨õ d¨{æÔKLŒq4yµ)ûN4Dù"ã1vÓú–L,on2¯Ç·—Û»ù'Â\:Z°X€%Jc]‘•3.àA‹ ¡ö€\ßÎs_‘X †|Hx;u?£ÈÇ/5º\©PlÓºtÄí#ü½U]Êÿ1Ôø»fêtH¨ý×2ƒJZBðÇ÷}O³Ll¿Of—ÿ0y½$Ó,`˜Áy4¥„?Ña%Õ°–áJÓÝaÒAä7V{9»1¾)É‘®„¨'ÊÜK˜LH$×O }˜ò º ØÎ¢ˆä"²äJŽÚ¹dŸEb¦ ¬Wªd1 ”bðŒ ý‚)ik")¾1ÉþVV)^‚.Òzú_iV{ü…o×5 †Ÿ!Q½>ó•ÍË(Ià3ÈÕ”BÝlr^€%À·ã>yæ#ãp‹Ge_œÿÆPCñ8ÇÆƒª±’@ Ðæ—ë1íDʶz¬ƒ3ÕäB”òôw÷¬íi*¹­æ좘ÃF Ž;8ÌB¦j.+AÙ4Ûy,Ê-Ô Ä”w&ußlô¢šwÁ"Gâô“‰h—·÷#Rí4Ý€åv|ø M› {È0bè“K`DÔÌ8žÉã2þñ«ÝñÏ éÌdÞ,üÑ4î@Š2ÖkÝB~C/¹Ü±žª–Œ.`T̵éî,«´ôQ‚²s«sÖ¡“ .’Å«”Ö ¡ ñǽõoé™â7ð¤’iM~/¢Î ˜ á<ÔÞâ S_#3¶—X‘–:Ç Îi%áï9îÍ3³* DŠ×,c] \£¹5Z$èvu£/%h4}~–Tµñ#2æüºï’Ä,äñäCuŽfÉÎLšH²©K$¢àãg›Ù {…OНÛ|Ôç^ |ƒÐJˆ9fßÙ×¼¶€(¸P/6ú‰/ÓÁy8ÉÛ¤>9ˆšÕ­Šˆ~-ð ð=ÙX¥>3äzQÒ?Ö–}gMb•v-l2ôp¾<}néãWùÅÆŸ€S_ÃÊ›áýÊÁT‰…#ç€%N©ÛØ=!2òé¤wiÃ=m›IãÍßC)ÂNkãVËfÂÚ@ ‡W± ~W Öš³iðÉ’›û¥¾rå¹/¢ªa¬ùsΡJª³¡³5œ’™Uú^ö´cnÚQUONÕEëqæºU{Ĺ:KêÙ™~¹Ò’nÜ]’½Ü&8Ô-VY~ìï*$Øß ¢ÕÒi/`dN˜,Œ/ U™^DøaÿEXHX/Z$§ðõ› 78y€¾·çŒþ<UV¤ª÷%k™›Ýé„Ëõ“cP>ƒÌe”y8CJ dVwÁqËtä„ÁÈïE;#rm¶2»‰êê§uœˆíl¹Å‹ôصBƒAs§ëÿäÛD[öîlŠôê£í,ÀI }€Á©ê9ËçõdêE‚–{ŒÇ5Æ*µ"ÿ­R[]³öžì¿·ä¤ê¾ü ÿºØ)-ñÖ O»¾q*Ï ì,F•ÞD0ág5ú.z&¡ÊŠ³í¸ƒy|€òÌlÏæ.†HÌ`{/¬@3`þ¦è´BµÓˆ,;aœ¨4uP9D†Dž’ëp!óç„ïôI ó4茗à$4Ø#3 ÇìT‹ø6¶Ôäªï~­G»WÎåƒPMŠ,rIUû"É~pM9ì|À·Á²8m*šPH™îäÀá!ÿç.½ý0 ¸?ãtóo˜Pè(ƒ£È²à¦ä2+2°xÁEeуÍ>FŸ{ެR>‘ñ´%ê–+’¼hûýÏdf¬Ñ†2¾®¯º(ÏyudÝá‰ý•&ë]àí§0qßàêÀ®âi«¨²s¸@êˆòz•Só~YjÄ—,ú æY-0‹¸M³qíã„/I¶\¬Ë- P´ÙƒÂ› ó__9¹D„(Ÿ}•:ÿó}ÇxóÁðîÓ\wþˆ±·uzÞoTT…rÞB9Y(åB™yKdcœ~&6ä,A8ëÍqr–º¢8'1‡â4%4§!· Çì”ìû?â£OH—?vÓ‹“Ø‚„ø›öÝP ÆÒ(~koÌ;©ÀpðíêÃ+¢¢yž pG£±wõ½|Èßé3 U ßøa›’pß›:̲¬…R2·eŒõ…Ƥîè¥æD D kþ؉rËæm }ð ¢é$D.,ûyE“Ó¤Ó™J+Α›§”}†lŽ6ÎNê¿ÃNg|ºf,& šø;PÚÿoÁCP£þÓÝ{¾Óš§Pňü?DÛ_‰˜)kQ(ñH¸:Û˜wùtÓ|P²N/Ì;€g’vÝ8bÖ§.ÜG­:Ô[^·æHúyIX¤|TŒ´&´>Ô°évŸàqb"Œeâqsäë!WvîU¹ÍBŠw†ϱjp¾W¾æHué@Ôd m Ý\ŒË?þlB ÷E~_]1OF¸è£›_ød©;Hļ±ŸÌíÏr¯…v!Vë† !heÃò)²×¿äÆ1$qÎwIz0KL)Ç»ìÝM«BÄó[|20üUøn—ó­&Ý™Yælì¡õA…ÒCi—°ªœ‡n©Ëg+»¼~úiÖrÌ ùfè u)1ïêô*[¾cäܳ/AÉ‘üÓªÅ<±«,BÙ9·x7.†÷D4™Ü"Ú9÷›Ç¿øÓ%Ls \oØ3%.s=;ñv˜|Þ é ²dès'oâÅùÁ“AÌê3Î÷å€Ë32{ÐGƺ ôkˆî7;oõ(áë ÿþ­ØQ'òÈ4õÆi{uïÝ}Š ÎÚ.ü}vëÚ"E-L‚)íg£5øÃªÖŠDö鵈üÞ£6vÿ§]yÃöа/ö6¾OröBTº¯¼!Œ=nÔ™å†!~y="ÚÃØcô œ8ƒT7Þ@ …É×”«î5Sñ÷­" Çz^6¯þZ¯ù§e*d²YWØSÑ”%MÅã ŒHY#ibýaTÜ ÓÌEÓ|ö ÈÊE6ÆXç»Sl:¸Z©^£€ELTØ)e‘Êì7ó=œbºs`rH}BH€Hvˆå°kìNïˆgÓdÓàÓŠÆÚN¢ÿ)vn4 3BJ™ièÅ›¬9‘šÙÔyyÒùÿÈצ~wõ°Õƒ×xMÐô‘V‡ö¹8˜å¾ˆi“‚О©šOŠ©3=>!ɲ–jc ™†®•@ZŠS5ÛÑý¬ Ó¬ñ©2Mj§‹R42?„]ÇÁ1¯.Ø9JBØ£‚ ¥•=êåÄøŒ}ÿÉinènh¶Ý"B³Á8ÿ)þŒEËž‘4EŸ!TÛ&½4LRUp¯†ÍÑÅ„ÝBÂÿŒ5œ|o³=÷ Ô0dˆ7¨jà ±ëÆ²øR_ŠBÚàzJ¸«Ðéš_Ú1àh¤çNµ¾H¤DîF%7‰[蕼)¾'àM’½)÷÷­‚ó½K ™·#ýù—îåm˵/¨ö„¢…/›ºÓ¸|¡jržV#+g{v_ãßÖŸæùâÀÞ’©n6¨ÁþZhÏæ+‰Øµž}Y笢K#­‰­hˆ¨SãP‰­ËúNÍ;"`ümnÍœ8<ω˜×-ÀöäÏ —«¡z~…ÐæÑL€Kfhºc XñnàhFŠš –0ê¤y€ÇÑKËAð$øXDŸ¼, š±ª–,B-à¯PéÌãê¼È5—CìFpÂ¥±t¦Œg·+J«wkáö½¬oÏãdˆÿîo¡ÈžíFz Nç<‡ö&“Õ´ÞwÅú¿ ä^sr|`¹Ö{¨eU﫞¬oy~«W…«#Z¨ï÷ß.Ž6#_«7Ýp¹OA醿Û%˜=Òi†‚_Üw Œ0«q üí_‰ßV— ΃öVî˜3—¼•;Áz•k• ñĬ·%eW„þ£i%ðfuÃvu’û[$>|((T=ç£ÜÃ3Yýƒo¨Ë8Ÿ)h¶©YŸˆ@n·}šG<é¢c{$çØèÑõv©—Õ÷~“¸N› æV—ÌR*Æc‚ÃzÀ¹Iá¬íp-vT´OX¼J\ª&Ác_9ßù7[˜O^L ¤Àã÷nA¸ S/–§žÓ&Ó:8ÞÀ¥öF€hÑ8« Ö(` }MþÊÒ7íJÅS?î(Ÿ`i×QÅ~“¿ªéIËZMш٠¶1­ oÙªƒÛïæÂ¶ùsìõ€c»Í£‘—D?B&þ£7œ¿09wçÇæ$>"¾×Àüê*²PBL/oÂC‹Ð¬ï²ý{òr`m¢ìº ¡DÆ—¸Ïã­à«ž««È¤•ò˜ÝL# ³~h³Â{‹[ÉÉ=_ßx J1C×)÷k÷:’æúp…˜ux ùŠO,׈»ŠÚ›Tº › ®ß°U=彩Ëb ÕPhýâv!«ÝƒËfºpu;*ð¤Š~À´]=Õ*z#5q‡Ü›õRMÙqQÄ1Âdq#ë–8I‡Õ[r¢ÇJsƒ±š¬»éÙél¬zõ!Ê Î?žÊsz·@î³Xƒƒ‹D›{pdë J:F€B{èmÄúR‰86Û“Zè4à›‘so)’Ê,ŽU`ÒœûÇgqIŠ–s¼¬Ïs8> ¾ÜâÖ zvwTN®ÆŽ>Œ‘iý=Y1ÓÁ¸>‚W2ÒkÈw"\JÜr—ÚN Û@T;Q6¾¼mù1šDuŸOKQkí}¥ ùç2“ðÚ¨#jKžÇ]%[SÎ/ÛB¿Wèî_aª§–p,k|ýýФMÆ Û‰À^9!¯ç´ éQMx$®c?Óz©}1¯˜ dÄG2ÙÊNFQ~Iñ <ŒeÑœ‰Ÿz`åÖÄÿX²¡È×÷ªëð’ò@€íJ¡µFä§ty8D&êÀ.ëÈ8€ D>mûØü–Ù€`¬W5íR©ìf[œY=$^¢`»tœ•Àd£íxÙ~Ë-×¾9äj_¶RLaài6ÁK0—Àa¢-OmÊ´ zj¾¼eÆ?¾ðÔp—ERqR˜0-Û [%IÕ›0‘«}‡lË™™¾Çò9Ÿ@xˆ€!#îwDcSå_xC߯„o>R4Š¸Â $´L‰ÿ.jÚ%V¼¸Õí;w 2ÀQ—?Þòg$å0ñV¹ú§{¾Y<)ä˘æÏÕüÏ:d#WrCJV ~gí,Š'Ɔo˜þÏOs†ËJ錾4î ^~Ãåõ¡¿­íŠãG‡{Ø ‡†³PGYx†O<µ1mh–¾b™m{ß]P¶šOŒˆS<¾…”ªpcÀ*„ëb«˜q¿Ûñëu"õ r׎øXl,ÑïúVðIÓۓˆ½ÑäÊÕáØÌ«] æ%2‰ëŸ`D–‹Í"[~Å´ÓjÆ)åýod'lÞ,úÑ.ôÝHCzèÒÖ.“[J0¸¦þR y¶Qê8 ”IºÌ¬ó>™„àqQôÂèmêf_ÍtµƒÆnÁ½ ˜ ÕZutFëØ,³´·¹W°8ÜßBw»ÕÊsCðùÕÜ—þ³_HDÿ€–O­4  žqþÁ°‹½=ûæ×NöÞ·húè¿;OÑd˜!œJúáP‘›÷I—ÈFU ¤›1ì(X?3Iga½çH‚둪¹GZ¬Ž!"cŒÎkU }ž# Ñü^“œ„½ÞÃac(â¡cA¯)å |‡š½TµÀ¢#/&¤}ZÉž8gÞÈd‰­vœð‚( 2| Ê9Ì€“whü °?&hÉê[Õíàóî3kÿ|§Õ7˜,Elobäжs 5Õ"<_oºÝž¤dŒBwƒ|=P‡^Å´¨"`HеpüMÃc ‘ºj'û' ÓtŒ@Yœ±d¸‡NÛb äR;e’•¼¤ÈÈs=3ßqhÚ(_€ˆF, ²25ÓQ)n‰nŽ·ì\´¤²xtçßÞ¡9±ò˜ ÖE T^QÈg<ÎúCŠ?qúÉÿDZÊ^imz~,ý,Ç]¤9 €Ý°·%Ư[2=w‹¾tBÁÞ€6w–Õtåd(nKݧè>"ѳ Æ]šrF"ž¯Ï L{®ÿÏîÈÙÀh 41³ÍOº!’Êr©k°†ÑÒú€ f0zá/R!šiVØ|Ɖ«½™íÌÊI 8bH€;ç>8êžä"ëJSŒªqäˆñÓÔdxÐ%£ÚEÖá˜?@LhÛ€ù+KV¸i´3Ð(yÈÞÃÎ3jbT€&çÏT aƒãŠÊ]öÌ|Çäj“•Ì¥81âÊÿI©!VÕy«|øöZqšY3HæŽMh;܆z÷À¾µp!Ú<× z„ ¿¦oÍÞ|øœ¬Dœe*>¹—šH“°ëËR ÝžÿMü‰idËS=%Õæl5—ñŽ®Öq·2ÁÑuß™+‰Nœ–ݼƒLç;þ «‚gi¸už:ÎÈ ªÔ+ǹ ûùrõWË#bÞX–-Ñ~ÍGzbï`5Î >ÎŽáéæöÁ¥[H°ÄïKxç£85‰„{)V ©?ÏNJÔÖngÅøÛJ0ÖæQ«û=Êü” ~Øõ R,…ÈÊÔþÕúƒûHä–·Þ·çõ%I|¢ÓFõ,äK¯<3hÂp…! ÓäËDÕ†g@~X³„¡á ³Ù‚SŽ+Öæ³ÆlV*0I÷ÓZŽýÔ˜í*'ÅBç°–Ì1ú£½ñ *ÓwÉÙ|Ì:T§²Ø[<šÕcz7$îƒy’ò{=ÀÙRÕÐÍ_„èIï…ÏÐq‰2i¥dk`Ê"·V³àžv„ç/ù»ñ¤êrΨ¼6VÂ8Q –ŒõÛ¯hzè´'ôù®SÎQÍ{‰‰ü!:Ìœ‡5ê×nøðÜ'^«¾YLdÈÁà`ΰv'Ãþ—5œÄES\ý) Í—*ÙPWd0ùû÷žQø¼ø hÎñ¿ÂšiæÈgÂÿî¯Ë~Çp‹"IT_ç<•Wœ6Ò¢¨I®>°XúÝôZ¼Xr¯ÿkSÑgŸ»¯¥«Ñ%Z,S¨õÄò5û•\¾gðHN<· çÖfÝÞí£êªÿ¤8ƬTP ° Áür+­n²dÿ'‡X ã}ÏOhÕçªûæœÒ…'ÇÜhxzŽ!~@«L€ñÜ á¦™k‚A8Ì |ÈÂ8„yö¶lK? “ÉL ß]f›­‰÷6ל^*7Ê(3M*¦ü‹7ÈV0®.gíbgøÎDšœ;YD×Ñ8´X¡Ó > þá{FZ:n=W²«Œ?î¶‚¬æºëÈYM˜x‡û—´Žo ¿Æ>¥wA–²¡ñ×7áÕ®V¯?I‰í7âžù·ˆK|ͪ1ù—ÕáÄ;鑪[ýf¾¹æ„‡Ìµ;ú¿ !å{"®‘³Õ¨Dk† ØQÊ!MÃVgê +Ezwjãþ)åèwz!=¶ôŸh"GZ]IexYk2éRïéÏîÎD¶Ü$j%Ø;߸º‚Šp¤mQ/>ônlð'g*ÿ»¹ú`ð¨;a8Åä@Jú.ŒHŠy`¿‚O3_bö®¯EU©ÚH<ø©b‘K²cuÕå×M9–MDï†[çnòV«•hÏÓ"¹uÇì¨c³“ä[­ùôº~Ž]CìgHjJCƉTü×ïp%¶YgaHNqÊ.{BƒˆG‰ˆ@¯…í"à!<¢Aè cßnK]ÑkXàI+¨Ú$The¡2vK× ÙÛ6禚AdP'âù¸Ý‚ßå¤ëa¡ôÏÀ¤I3BöÊ»¯hôúƒ6Hc+ñ˜©ÚiªçP[£Õ´ýà©¢uè¾íþ0O1=á|ZO@¶Æ\ |r€÷ÓÍæuÝ%4K]7•-´öÚΧr§ìdRüuÅ©‹Õyx¸dmæ~„¨×S(U·âŠÞ%eÓ.À/—[ÜS=-Á¢£¢Å0nÌ>¬”C7Á3$Ù¢wjϧœ6u +…: )o†¥1¥¸µûw«yc»ÃlO¡ ~„†³<´“´íÃUA¨_?:Mƒ T-!ÈJ[øåµ_àܾߺ_YÜŠÓÕ¾²âgéÝ} éYOrÆèŒŸqhNLXM[—ÙȯµhÍîƒÏ×â߯ÞŽä#ÉFN¾ìnu‹8ïFôq|å°Q`\ÚG€bù‡Wl7ðtˆWqL½¹Ëcdo4ÑÔ¨µyƒ„Î)$ JY¡lõÏKdÍ1‡g¸â<§%á´ž°'Râçðþ]ÀÌtÏ«æ+y¯BÇ«µÐظí]ÚïH“(~q5ëÒEÒ©í&}7û–B´P÷Åãêåv Ë«[áêïŸÕl“χ:Éqj¡(Žq<®Öt¼øÓ¾˜íI\ÓŸM¦MHâ·?to×e„´E6I} žÇ} öÖ%Éà^(œá‡*JÓw…ÃYãõ²×IXÝ–=޾•ðdKSœQ_eêßP ´ˆI |i%4tõÇ ûiÉ+¹r^‘–”S‘]yUà$€F,ïX¯5Û‰åíüÉ7žéVŠV—  cC«Lб¥ÍЂ›löW×ÿ«=?úœIìZÅ!;‡±°ÿŒìæáß] ™ºLa9äpHÆWøÄ‘¡á°Ý=4ÂÒ±6˜úûÞAd+Cjó@Ðê€iȺú«L»k‘ÊnO<Ë&˜ãež£·âýr–ç¼4ó‡Êb‰uxfõ’zU¯»ùˆ£^ý>0 ‹YZclubSandwich/data/MortalityRates.RData0000644000176200001440000012144014630154051017472 0ustar liggesusersý7zXZi"Þ6!ÏXÌæk ¢á])TW"änRÊŸ’Øá푼’ÝJ ˜ šzE‹#w+:)Ðo€î ·Ãus݋θ‘ìëÄûs1¢ë¬±ü­üÏwŒMùÌðqh§æÈ“Ö,ßz=ºe°Gé¾-8¾8$4„º“=¯¤”z- þǨÙY!yx ±oo”„ËÒ™ªµ_ºGr³Ï©w^›à`쮂ïTƒ”Ÿ¤mˆ"Æ™»k>[£Ê_‚b+˜îsôãþúI¦,ômÚCÑŸÀ|èŒ,®ŸõüÙÚ>uÏø%AÇtdºÉÒ1³“[Á¯™íëñ´îK²Üoø%P×uc¡3ü‹±°@÷T;þn^ÁdÙìÞí~¡Óó}?[ØñNUG”òÙ‘a²ú{MBp‚Zè²ë¨w¶œˆÍ™îÌ›ÖXA'/ÍôÉ›ðZosk¾¶òhÙaƒö »M$æk% ¢úU4‡à*¬ì@F®é6UU?*Oê>ÖJwê>ÑD}Ê%1 »Ø§žPÁ*rX/°ÚXÔrî°aÚ¥¼KÀ·Ÿ¸üpYIo€¹ÓAi†ÖØw¿% ±¥Ô:.”8r n_Y2ÿÈË ·<ÆœýåH$fÿÜþ<æedKPeœÞ`¬gßgR€“‹5ü «{Ö6TÝàÚ—¼Šø°"$íjpŸSJÆf`Ý ¾û74¡é1†-,Žúz"üRÁÆ”æ¨ì—Û®Ô£c¢#YÕb ú¬bn÷NoU_*,˜ÔŠÜ—ƒ2tò“¥¬]"zgúÙ=fÁ¸Ï ~\î÷¡·à¾CÖ´*[Îßõ5 ðPé»b/ø!ï&™Tc”\-&“뮜8˜¬¹…»(g¦MçyÝ_“øF•+RÈ¢žÎ3Ê6RäΔ©ÅࢠGÀþl¢¬Ø™n5ê(mÀf´¨¨¤ÀÅz}‘ñÃÜ^óqÇÛp× õ»¸Z,ëh)öÊJu‹òk6½[N«,´ ò‡DÁ¢Ë&Ús¢ÿdüè5-°t'Ý‘ýSçԤyÿüY€Î{«I:.~²dwB³]Ò‘ß LЉy¤>2J©¢.:Õ wKÎŒ¢88ZÅ4Ä¢Ôa÷A§uêS_¿ã#D$„*C닆bÝ&ùw9”Îq½Dbgí¼Åóm{Ý®“ãc—pâô>²¬ÿÖM¥‰îÍ€Ç|Ä"hn$2 ýLWø»aõª¨+»ñ¾JSL@+¨Y|:ýÎØkBs%ü8M®ú‹3G‰o@æÃ,ÁŠnK\nðSPÜ‚äƒ5¥ädf@õó§ï®#´Uê<°“ ÌÈ^ë¶ÙâËÂHLxìi $·“W:TB$QÒæÅù„ÞEèOÇi¸Ÿ#¨0ßímš`huX1âbwI\ÏÚ‰§ïqGËIèT¯ã‹Õ(*¨²fíõàj›§²e!®Ð¡{ŸåuˆËSŸ¡ª)›žêÒV«ûcf§.š,ÊRúS¥e Ž“€/÷ï¼¥¡ø…j k2Œi Ì©b^ûª”s¥†'[8D=àr>z}°ö_èïÁ~õ>á6* » ª ¿ Γ“P ´²…anŸ(Fö]ša#ê0«¡EïÅP±÷YÎÂu•ÌÒ÷Ŷ‡‰•Ô2a›rÊ>Y$ôH£Pé[ Ø\t(2¥ÔÈ«Ÿ±ü:ú1² ²ÇRüÄÏQš{.q^W$6 ÄÕŠ¬Óëb¼yÊêbšî §¿.“'ÌMï:3´€4;Ü–kDô±ôSy„(L·"¦\Yvh £ ÜiJ?ŠâÞªDßôÐý™ÿyî½Q÷½¡bû¢ºèü¡sæ´–ÇÎùÕ¡IêÕ¡”u^¹ý)þÑå±vJæÝ©"jËMd“PجB|Ó1k^¤çã¨KÍÐàTÕ{`ÂLn<>`)p¿´6Òðåõ ›ªþcQC›ô—*eqãJ×-«S*y?ó½\r·A6¸}á&$(|Ðj•s€ž^%ÏŸk›”;„•½±W/ À ÇÉ€6e¤QÒÉwCY¨”üé>½ÚÐyÄ¢Ãï…j2° c¤ ƒ¢·¹z9NߢüdÈYµ„ yèò­Ç†ÞL]7?”°únB Óž—Qû"6½Ývfi$L‘töùø‘pRó4jðu¥šŽ,ÙhŽØ“AIZr¥À鈯ÅZ S»‰[ ¨´ŒŒY¨J>€ì ¯.ÑÃßœRv~ê—Dú‘@EÀ²¶µyð8ÇÔˆëüŒÀ÷ jôì{Õ‘¿ÍÖ1ÎO%Ì2^uÕbPÈSXþôýçØb]ŽÅ7‹L*ÞíÁÀî\ëæT¢o·âš4"²Ï ñʫĥâ )œNàzÝ¢‚\ã Òþ~ð»ã‹Í˜jÔ¯[BÅ,wfr¯ƒ›."Ú þFÕû{ã_À…’þϹRµ*·vv¾XY Ãï_ù³ Wú315Írz˜µvÉ/•ÂQþ«P!ÔÃaE‡¥ÿªäNäy MN²)©&JˆRjy %¼0ÝØ?€á,„öZ=E£ƒu ÈÀQßb¥‘§Jç¥÷nï$NËî*;¬‡ÌtIâ°ßFmÄ‹ð× +H<$EßÐ?`vnr¹K%':Èk‹âʵÈ]²‹¦+ó§Rk°»,÷Þ ¼C„ëØÃ£¸ÆV7é ¸î´ùÁâ§á6üDKN)t^à(ÑHÌÅœxxIjkA¬z,ÈoïÇýcØÅA$ivJ”ï×n(ÅÁo;Ò\JÇò-¾ÿn2a%M®JãÓËÿ~U|Ñ<(ÞÒ5}¨tÑ㲞3¤Ý($)]Œ/Ú–Ù”1'ÔCΕ\.ù]lm¯F¢{ˆ¢ã–Ôþ}egxÎñys‹ ¤"3Éýëcmk_½@’­5]M ãapjÑ%QI°Kª ¨ÖÔ’^jâ"ËFäš?+ß ÐO²båP}GÔßîaÿ6ýJÛÑ-CÊM™qk£5#ysëu¸f¯L·³"SÈôµ÷yÏ–ZeKwÝžߴ‰î´Êé|&P‘Êû…*µBÑüt\¨L[t}x%ðæ÷Z|; È/stŠUÃÙ®}¤ù+®-*[¡ö^c½{¯qÅs1ëc¡ÊX›¯„·äaÓz–?¾è ÎF&TüÖGÏ‚šÔÇcè Þý¸Ìék °»ÍôLrU#ÒÀãW‰;OÛ"”…jÁ¬Ê¿+L­¶et8zm¹²×ü7N5>‰¼XwóUÒ©š.ª96&Ž;iÀ9ý|^ZÚiÅ'[w&7ãÃî“j 4uBœ<ý†[èЖTÖ{F©þ´ÒöÈÙ«:ðH ôøý;}`´\k=ù€^þR}ý‰wH7 »†U£%ÇÝþJ§4‡IÀ¾ü«ó^ÀÙÛkÍæŸ›<˜î…«\«ìâ*¨AL¸fwe‘È‹µtÞƒ³¥È OßÁâ›Ü/>O/³Ž||ç*íž`‘¿wMßœaºØI¯Ò'9Ú"¥ã¨à}Õ{áÞå&!ͽ$\ÂëU…ÐBp®©Ñì.Gh8 “-Ù°¸úÞ{¾Êª¥Oðõû*ÓV.Êxj'fÒñ¯Bq`Ãpé««vëŸ#%ºEjÌŠŒo  øÜùûh•w)Ðö7å«0àf¦¬€Z}r!ŒËߺlH¥T2ó-5þ‹Å­b©‹ˆä¢µwÛÐm‡;Ýy‹ê€jJwem–·ÚÜlˆ0GVÓÏ2‡P+´óÑB=l2y%jÈ%Ê•W¸pR*ýÎöÑ”t·Çc.Ü'˜¬–X$Q O¿T€„Ï–óÑÚÇ9W.j¤^˜<-¸é]l|4Öš0§’9¬Æ"Õ€¢·q¹Qȼz7BvéE,dÈ!ý™«£hu…Nò‡ÊðŠ}lzuoUþ7Qû.ê^kà¹$T†âúCØûŒ|ŽbveÉçôMC¦FËG¨Žû¨ê˜n~ø ÄßUƒ¨»M+ܽô÷êËùÚ¨.&Ê3P5žšJF&Ÿ’²ÑðBc.µ¥€_·»‚‚G#KŽû´Úw={2:hòc€‘zd#0ûù}ÙÓ¥GöDÔ:Õ›|¦>ØdF©d ,ìç|q?¸â©h¾fNݰ“[„òlB¦’w $›Ö°v'°ãŸï&ÀàYÛ4®@( _ü;÷G÷Ï™/Åï“=ÇKå¯)îeX¶OTdVA v±ŒS÷a=GTÉä­Ùqݘ¹Lçï#éþÐ=^RÎ/—M€Åh³‚aµ‘ìôÑ4 äû%Vy^dzZrä¿}ý–Á4¶$g-ñ…‰|v£ Ìá”N¦yøî‘ ç]³k[D¼Öó“úæ¶²8óƒ–ƒŒþé0=e­¦^ÒÜEܬ'Áº†ÕﳌÍDAFÜßìr@·“¼Êâ1åñD|Ë·ÅPäÐUVçóǰü8µÞN™Üí\3 }møM*µ^Û:»rç0ß!gG2™€~3ûù*9»!—­ Ä1UU0È’ÊËyÁð"XáÆUÔÔà°kö蟛¿dÅ'ëÒˆJ{4¤]1NíàQ/棽d~Ÿòzq2ÊÇ3L¤þ4صyr®@²hu.Å ÎãªÓyowÝaWl“{d—PoµA»iz‡e D³™1j*MÙåù§ÆÓ‹}‹ÈõqãÊ:˜$GEÚçFÌ<èÌ'ekNÇÝŠÔÈäÈú ))"|¹óÿGq®JA˜óÙµ'Rܵ sàÚ"*ãíTƒ‘òÂïME²_˜ý1hmP3w¯,F>ó¸$áól † Ž~ ñ(U¨áýJÝb´ÉÛ:9çJ+þ˜‡Q&„º±²Ö;¿#©{çá¾é“TعÒ!Ó]æøü¿Ï‰ÿ`Åw`:òމ¡àLÆkQ$ÝaÃø’¨H ŒrëµOT…g óÂÊKþ–›Ñ8]:2…nvž¦ {ã¶wÇ,êhSæv…[é’K/bc$҆ɮ5æžûü³6Î’^8AðR$(h‘(åÍbÓX#óùž Ëê¨ÕÐˬÁúØÏ·£!ÕÚÌ¡6¼àxûV µðf ÷ý\´m›ÌVùÚ¥_ K½h\mtíú‡(©6Qðâæ;þ¦)& /â"ú‰zdL*Ê\Ã'ºÕYü/dÄv2ªÝ0äÏN£wб]_ŽÆÀòWùÅY¼Éœlgø¥zwðÔQmêVÄÙÆ¨B ¯ƒš¢Ä¬þj–ÐïÝuéæâI*Ûêé *=YÒáÆH ` âw–Ùå®Á7Σ!J9!|$©$‰ôX]l]Ëù ß“Ìwˆ[8†Ðyv+ÌH3"lô%íN¤Ób"SE›Ã{GU=¥(˜ÈoÑÆtaETþ*Z8(ÏHL e°#†ìêŠxh|Èñ¼yS[‹Þ#Ä‹=™®\_ù´•! êAgAi1_»i~¢Ë•ÎxšŠŒÿŠø}&’ðWJF$Vvþ ÿ—$kV_¨(*<"ôƒ™Ö*€W‰¯¼“”\Kžk­îÔ–>ú’?åC3—d–c JÈíÃ7 Mç¼…ÜKrc9ìÒ…¹„Bcí“ðœ¶Yë5Ç $ìû >ñÕú^ø²Å_ñX0kfc†‚ÅžÛX|G«Hæ‡ðÜíe¢WÌBû¬ùN>PxRÌMËì‹ìÿêÍÖÜŠÝR“d NšU¹÷’š“H¡Àc´ÐfQE~γËÉ@Þ"V¢ Q) °P$ÕI†)Îæ¦ËUá—.a$à+©O{lÁÙõ8ò³8h’ äUÊž:äCJ7¯ʹ&qêbÎ|Ã4?£” <©hæ¹Wºë²SZwG}ç´5_IÚÕ‡[ðg ’¹wA­×× ‰w_ï(2žï)*½1LÄ(Š–áø˜¸K3ßüpÕÎ~-(9ÊS4ïQÎNà‹×uI^/ ²5OÍÙEuúQ}ÜÍ0 óV^C±þ>«VؚŸ~…“y•÷ðõeñ$3\~Ë£Ýå-M(ª–´ïKbJ—DÈng_¬¶a…Oµ ŸØ'ñ}èÍŸ¹÷ êÍS ,úl/"’ü3Eò™ÑHrŽÅ“ëú¼¥^ëê¬k EäàVI4¹Mq]é’û ëÁÞ°ª£Hî¯#4ÓO œ¸{Y†úKˆ/iVMìZ?É'ødšÐ¥¡ŒœLŒgÝÜG‹EQÁ£[àò¢¹ú˜±ŽC¥ñºlÉÑt?Ô‡†îE|¾µøž³]ü¤tŠ•@»jϨOŒ¬!Á•oY•@"úO!"Yìl­vŠi³[ý¯HìÞq«)Âôñ¢Äÿß•¢áÛoä¶y=æ":ãÆ”Œ¯LpãÉÑãØÕÛuÆŒÒ-¹±|Kð5\æw‘ñkR]rëúGâ?ì©éLz{™€9ÕsD‘~ZÝ0s4ûàfÈ[cgT¯ƒ3VOw_·g&À™LñGwàWïG23¬?úë‡?´½Š„­„¡×bÇ—¼9Í›}™Üj¯íË)øÿX9À¬è‘6Ï-•RJ³ß`tÊF„ï,Òöík $n'9ª®t?Û‚¶-‹£¹L³¼6¾(Û‘OC´íM6.FV£ºÐ#0kXDëMŠ7²ÊJ§%Q}Ý~Évn¾&:9¿ûÄÖ~žö°ÄÍØÀ ¸ÖAÿ” f§í#º u¥èH€N©DÎ>&õ–ä*à°‡Ñ ƒCz¤‚I…]Äš%³ÐBɯº¼´!i„H™•%Ï’Ü}ù°r ;¡Ê ÷{3C—äs&:‚QfC–*ëNC(¯P% ‹¢°všŸ*£Ý—¡Ò<Ž¿Ü%|Ûon‘ v3’QZH@`Tó<µ,z¦2MÞäJ:õ^™ÊÝšY L$;á=°™|í¿Ìùu¢¿Ö/8Ä1±Eaìî•­|‹®{ó«hÇBv™-CNô˜¦Ú…WÜR™•_Î÷h#™ûÌÏl7WC í•’gÜÈÙºbÅàl0›Ÿ>tŠß³ºv36©Õ£®ZÅ2?krM»|î­&’ðlDâ†Øe<>8u£ûQKYΫõ¢´ËŠD!FÜ*iº`Û¤æ¦ã¯h¥²9­OÌû×Ò¨±÷†ä}¦¡c÷vŠÑf߀ÄmÏqS:áB¡Äšñ­ðJËÍÈ›¥äPƒ*ʼnq[w£V¼±²¤q)yû½\ª¬dw?,Ôî6WùÀi 0¼z‰í£ã$2‚OÖrÔƒü´>[»ÿÓÒ'œ}%Á²i}–—œ·ï!lTбBîAÐÃÎØ^Þ곊¿sd͘…Ù °ëëÿÿu3L”:%³Ä&_à“VÄZZá»Á.WžK’í4ÛÎÉ æ´u‹3w=j®bv?E¬G¨ã¼’Ü º‡wî– Û 9OBBvûïM2Œºà)Žv×Y©yD·oC€Æñt¦«;€ dWnFs ¾6BUê·Nmlo‡×ëƒ\çžRäÿ¾îFè® ~DjÁV‚øN¹\§Ÿ[1±ØÄÕ\ÍçI&Q¢0n¹ªtbÉ’çà%¯×–´E¦ä“)XVÅëÊiõkD2h€{føVÐuä¹…g& ÌrÙN†tEÊ“€[S§f¦ic0¼J}m¼añ=¹=»>½\üз©7îãŒ]ú=w[“µUq¼™žÊOv|™¾;1ûnµîEcríSSÌjÚ÷{ô2 ࡌSåŸfÂKlä¦:»ð6Òk|ÿ ŒßħæN|i½ø0ûßìº*®õZ(›×#ð‰+”Ç9féq\Ðqׂ¡ë¹—Ç} -žÿ0KUYÔo€gzÌ÷¶jï2žìÌnû;-Ý=iîº@9ËÉE¥ ¯ýì¤|„ †ç˃²,cßPR-ù·QY­Øó Š˜-Š172XDµâÃAW‹ÍFÆF£‡Ñµùä_nb«_F.§D(jœH¼èçþ œ"àF3’_´ËªaQÜw­ã›wY¥ÎW…aèÆø;¬‹¼_]“/ÁÏ6C°Ëìqvx;½3#œ¸bƒ÷œL@é^Ü+„½PÌãè?üúè¯AâÏ6¸Éã{ƒ¶ùrÕZŸûÍ‹"”m.¯|y„dØ…)cÄðìnzg>Zÿ>Â*Àù\¯-:=\øn9¯¤¹ˆÉ^~¦§yv,-‚(yCýÞ4–×zÈ(Æ 0‚Ú¹&5cZÕ¶A¯jõ(Ù›rårN*¥"s«ž÷Óóþ†y¢t ºz¯ö:³’sìh…êÓ«XUÔÕÃ&:F°ƒ ÖsÀñ‘à+Ñ>ÅR,»fNí._KgÔÑPzŒ1p‘ð#†fJƒO Á^_#€S=‘Ü#œíÌ<ÞχŸQ™¯VÇ®OÑÙŸM£°aMÁý5SEHVÓ *ò>';\HläzZMC@r²UFÑŠCµo1~¨Tyégí ¯¸saŸŽ®]R6©Nñ]“Mîr¯*þ}}YÇqáM¤ w%©¢­vçKåjfk¾TÏŒ-'“#DzL¦Éð–2Wc½cj(Z:AWY÷ â1 “] ¾Ë¨qŒ#Û¿´ËIuúâå¿!Ìò«z´ƒ‹$á§ÑhœEDMG:=  x˜Y…ý÷1´»x ¦1ÿó¨w„' LKZòj@ÈšÔ#œF)M­œÊK­Â}hYë¤Ü#ÖùÎdv{ŠÚa(¬Kðjû¨Ì:¢žx^ ì¸n asÖ¾Y¶+`ø1f®Ÿ—-Ù(qhþþbu‘8ýjÔÚZŒïc>axdm è-å*ëpvvlCåáÇ™Kau8‚û-Ý?ŽÕ‰œc|¿rÖ“²ãeŒvØñm ”LZ™KŽ£5:#âo–†XµÑÒU½9=„4žqc×h:‘©âŸð¬&™÷™FÓõ¶×’’tû»ö©"õÔ<Ÿ©Ê+V³ó–f#I´yóÕ æÝzçP`Ù¾ÏÌPïâ%}y¡ 4ïïFsÀ°Û9­lƒ›sLa8H OIÝ8g¾twÛ°?Q]ø¹OqAq'–ÿ ÊÂÏ¡õ¯XæÛÞXý“û±{ÆZ~„Ì”ÎG¦t9þ, œ: ·$Òk…9,ÿ:Ù4¿À¯R/Oùê&E@­JšÕ¸§`@ƒ‰gX.4Y(H㎖c.íá’sÊ]œ›w§+ÔÑØ xœî»6|½äW'1ØŒRdS2ˆÍ/ù7ÒÀœš˜ðöªÓçÞ 9n3œó`=AÑ»Áù%êÕ<ó͇\gÅŠ$%uh“L÷£yše©ÎúÄ Œ6w£8wÙ—WMðˆ¯Ö ‚¯ËôH}wÒ? ¥§dØfÕ¾t½‡µ×…od´ÆÎæµ^ÿTÈ~®oÇPîNÎbü;tê¯ÌÊ€RRyÑðnƒkwÃÐÝ$ïógä7_8ÚÆ~8÷Ç(Lª§ôL-ãáSÛEŠYB°¢ÛMíuæÃbtÙ¶¦½#J«|q_*&ø 9]̨¡)“å3®PÅŠÞ?îµr×èVI'Ì_ѧChÿEÌá™A>A¡,§amÛkí³IEeò½“ˆðQÄ6Kƒ9‰æ×nï@ m­©ÚÁ]9µ®ôâ6»RhÌoŸãñ9³5Ó{ð‡a{[anüg™à]öÌvä{ˆÀJT­Ü°ÑV'¥ÂêTa”Sz%?–ñÅ4ˆíoêOjÑ)&w\š#qmÕÂÈÚæ«»z|’oÓ´ G~"ÒçÒ©$ýêóÁàlG£«¿sÜ <²ä¶¸»*Åæ£ÿËäN‡QËf2Šm‡‹ÖäøÔ ¸ñ®@†=í<‡ì$§Š}Où‡Ëœ7Ï d*ãÀß‹Ð_1ø«¤ýï2Ò7ìòx#|’ï´G2õqsP{Æ×ðaDQ, €á*_JªKƒ¹õÀ BèDûÌÉGfq‘>îiƒ)ÚOÛ‚ª;‘ýEÅ‚‘z¼’/œo(k[37KcrÛIÝÜ18]o²„ðÖû7AX,Iy›=„DrMÕï¬#BD(&_þ1dËÖ§Ö¨Ÿ^-a‘¸à÷¸—õ@^ Ïê;Ïèa˜·$¡ËÆ„s@~IGb½F–*n­;7æ6 wÈ£ÓèªÍ¥³1ìûœeçñ0¨gþ–GÃy³©Ò;Ý%Z£W¢NLÕ&QŽ5–öRÁŠÍw¼j6ëYjýü€5m¹×ÜçÍ~Ô‡R¤n4͸ÆÒò©º%Ý•UÇ„cɆ_Ê´äfÚsE:r—ë=Ož½¦T1yûoÑ&‚!ÓÍ­ièO@ÙëFÉÀfÿ|gâ¾[ÝÑw¯GýÆãb©dÆÑ¹¨z¶¤k Ž}Õ O™i"uWG²ÜMMªÌ{he@’í•uCu•J÷­:-uØ ë…ÍQqtÎúÙÁ ç§‚¸â¸ax4ÂOõ5ˆýå–p?/è¹½p¾*×ÐÜÉÞ\ obŽ Q@³û@¨{Ô¯\, (å.ü ÆpÍÈ6»ãGŽÔƒÚÝ·„¦}ök@Èó¤O¤ ¡p{oŽ4>ƒÎ×pLrÚí«B€&>¥ ­?ƒê 8}¿XƒÑQ»¦9¦õ.ÿÊèÚÀn¾àP³­S—¢fèfÔS8% ‡pA‘U«¼ÚæxŠd¦1?Í¡¯ëîµùŒ±Ã/Uù%Ü­½¯ŒŸBè¡x À“HŒn¢¡YèôL§@'P0|ˆ†\)G‚U`3Ë™[7ûª­l ™ô±Œo`âtfìÜðF4òUI¬R¬ *>àZÔÒ[CuÆ™J?6tÕa Ñ þi80JgÐ]bY ýÕ †2Z>q´ëÐÞg&æ¥Õ`O8$ÎÝÆ ßÝc·ø‘štL'ªA‘{›Y.!ÖL¿Ñ÷wû/Á…è†+ìp†@·8g>²Ê]T£é¾ÍZ­-hØ—™^_×üÎ=ÔÔô(SM»ÇÚñl'£ Ð#ÿê<ñN7Ú é/©£[É—ÝðžãIü„RÖK­@”4ÎÍTJîˆ>jå<´‡Ý ðÌ'å¿zP[¨6öß8½Â³#îË_B U>A¾Äå×ܺtý#‰‰Vq&kaa?cÁ\¤o»Î n/™;òa>VôN®‚ZD"íñ„Z> ™Á`·ÏÎn¹jË™m¼cÅh'Çu6Û¿úEzÎ5n3­“ۤ 2-[¶ ¾xoÙÃAµÓÛñ­39«Ž=pLN 9³Áwë â“-{'Å€ú5¿ìZLFy1Ž r‰—´ŒWÔ§Ó¬]'Gh9†üðÈ›#$˜|êÒ^¹ðι7Åç©·|¶O¶åPKß?ŒŸÀã0Pãú7-ÃaÅÀàØHŠ EA¢Gå;Èâ‚Þe $Êl•wëCÄ&DE§$y†ñòf¨¶EþD_3)pöŽ6¹²Ó•ôÝhD•zy}=Ö„e©PŒ ðNuîji4’Ò‰¯9ãŸ6‹¡@ãÌÿAž»è9Þ×"$„ä£Ö.VŸšøŽn7c™Ox9··vØ&}%M HÒg†HîºÔg3âÜ«W=õ²¯ ™ñ•Óé§—Ìß4«Óe"Ûò¸‘ïÆê?ÝLËB6@iúß×D¡ 9j¢hAŸš0©Ã‰ëò!ÕVÿ÷¥u7³ÝvX.ÒÚ%‘ç´^¾ºöe·c†ZmJwí´;GâŒkæaÙ×ÍÆ¾ ÿŠëX´¦›tx ´cÆ}›—õ?.xõèŸxÊ:Æ9Å›4›VvfÕ}0†·]á—©Çoø¯:ç=.ú,ÏÆ…RˆÐÊíˆb¾¦ªã/ª4qÿe8…æ‘2lä û,ÜãÖ­Ö³E‹b·ìn–£Ýͭعd¹Åš=J[u.·Þ>èÊ Ž I!zºÆ.‰œ¤$~ÞÃ+Züÿ`*r#ÖÒ‹¹X2ÉjuìÒ9s>™•ûò 4>5íû„wÄöÕÓñ|ʼä}·’Œ>C»Kãdl],†ÿðïƒtÂln=éOè¼ÌÒ,z]~'ÄÂ@°¤1Z¬$­¿<³ózAÈè!ñ´ýHΔaK¶^ýTD»°´k'FITäQö%©xÑpÑ犕‘1Øœ n¥bðÇjBhPº^#—¶Ð;ûôçÝÇ,èž>áàû]©¥5ŒzÄ–öH(¹¬|ý‡+\o‘.abäo"ïdÚ^~8Ë­Å9—G—k"F’0âlžû/¸½|Ëg¹[¡@t Ì’¤ýÓÆi®Í‡ ’•B.JT†™Dh†Ò~> tœ:UFÅ€ð¼T¢Þuõˆ©ÑLºÄŽ…²ô¶lh]’Ycå+‘2!‘3<à l/«/Zk»}Ú=ÖöóA—œs“'‚»ˆsMµ^Å$ÙÉJƒ}<ÕqÕCãîŸ Ëñ£ç÷'á„oKïg}È¥ÊåÕ8’°k-tv þ#Ö¤|oÙš(É&5í³ÒÁKXôÉz9è¥к]|Ú:›æc1ûøfjO¹³Ù©”šYMÛÁD ¬š1ÔBΧ.+X‹é›µtxµ¦ËXIGïÆe±54Rà.^¹?KôÈ@j¸jý•­OæÖ¦ b’’¬£Ÿ‚¸Ò’­q‹“½äªÑúܽ'8ðm‰0ö6¶04nö¼+ Z·gëd£oÙeúaúl<êEl •Ø+O€R…;WÔã{‚ÄHˆ’å+GÂk„ ¼Û/‡k‰=Š.†e¥œ»›Z|¿‡oºÔ\ßHQ– ѯ¡"JÖ4nyƒâfãîÃæˆ)7¦Ë³6 õë÷JKKÁ?@Ç宪€™S·[¤sFÄÂ[Ç–åRƒhHÈ¢È!¾æ÷Éè }ò«oW\Ô:².<¶uô³KÿÊGÀ[Ât,ãŽ#“®6’“ïE¶sÍã¨PýmVy‚ ,‘ì•8goôõIOÑ<›ê½[ñ…ž®!–X¶]® (W"ì@¯¸ °ùš3Ñå%˜ß,i!°§æ\6g«á†Ì¢„iäWü×v—§ÊÎWܽC Fô»ã~Œµ)A.+…ùÏ變›G¶^³7Žú ¿’lÈðD˜¨æb„RÀÂ{+.uk9M™/¡þ ½GÀ‡S\µ(jç ™‹ú}g¡jTgPI4í“£sÜ5¸½Uû9°¤¸ECã6½^hz/v)PÍ8^»€…Ù„_T“?5ò´– ´°$HþDtƒFO*öùi¢îØ9:æW‰÷?w/ô¹KéWNˆézz¦úŒb0”H„ćH9l ¦ÏtÁE[]¢fö{¿ÕÁ/ÛAjšA†&v$ÞØš°ø [»\xÏö£Ã¸Ei¢¬Y´/Œ%9#OJ榕~}E‹j6¬Hu^çg‚U>~}t…HíôôuMk|Êè’ʵ¹'à3_Ù/«GËùaÕÑ®E˜yÞ¯_Dp©:ͱnîV]Là ’Ö‡\Ƭ‹õ¸9"WäRL’ÙäI&}ÕÌ¢c<åú y‰ÛöÂ,ëÿ:N½aȺZ›d`—íÐý0=•‚J¶Q»V³1쉬ef\¶’×Ó7çF”Á.}=L^ÅÅ£oßKóGÉRW1±°Hœ„D¬uMÝ0ìüœj¸“ÆK&O͆Sœ¡Âg@ÇÐãH¬TóPVt¯ÆØÞ…6?Ÿc´ƒÉÊã”3ÝoFÙNƦ{¸TIËö§d{û¹ùúìÑœXÞq}ô¢”¥}޹V$z ÍÀ)ðgÑ ÏùÔ©×'åøyH††õ PþJÿõùp /ÇÈ0IyÆ cHä6´ ¢¨žM±à"%ìR@`½¢ýšÿ.wþJþ,x:xqôÀñ°(Î߯O¼25· ÆØ³fE> ]þ‡t~ª-êþq_zCR']ì£i…¤‹/¨Ñø´R³<¼¼èq>W$¿d3 ÛôÞ ˜{¾ M¢‚›; é¹â?½õähSfáá[Ñ’ðzæËi´ùŸ›†|5­ôÑŸoûÔ_†›MŠp"3=KàñWD,* ŸëXˆ%Œ—­0£-á‹äx’PÝȬèæá÷ó2iO‚ÃÀCµŒHÕ 7²úŒftÅ=S+Õ?dvÍú€œàÝ=ЍöáéŸI`¹f?9ôøÇEW¶8÷\âŸGÑYÂqñÂÿ̧>=-ÍÑjËëï ,Y޹aª ‹ù²~\½¥bÈô Ñ]ní8Zm^/YÐ{Ïq…÷^·r'UG«ui û)éu5ŽÿüúHØmÊ·ºhŸ×ÖÕ{AqÙ_‰Ûˆ¬ü@ÅstFg‰X¹ë-ºÔ+ìž KÊÎo((áíBTÙ½ R¼^Á³™½öÕ¡˜‚ßÚbxOZGfo¦è+?¹6°ëX]=é9ŒùwÚŸþÜI#°Bn'Ù Üh¶§ <ÓßNÆ|)#lÍüáÁ¸,œX\B“_ó"ôWÇÅÛε©&±ñ#!,áˆÑ“²ÓõÙ÷k¡K8­lƒl€Åñç´3{ ^Ä"¨nAVOsk¦–Ñ{OÑÌLÑ©j’æCÿÊ—IMY+ãqº¼Ž…œFxBàC$qôPx2cihüõ•ö͇×ô‡ŽÁäi‚õ²ã>Ç Û8VjãšøD®L-fðò|ÛFÑW“D¥Ãü®m”JL”æÁ&Ýá¹å?œìKEñru²(P~µ}Cêœ!ú;‘ÒŽ¤È0 Y³ød”NŠ¡pbj䂵‚ÏÈÉÕ™dÏû(ü”  àGœÂ–óÃ9Û/°k›xnz7ãO˜òÑeÜèìÙÎyI0MW¤ËK–Ç¥ÜÊȣʵà²Ulv¾29Kj+{ùQáŽKY«$ʳµÁs_ëœa-n6þ k¯Ùxá–,©c K„U ìòg›$,Qÿãá­Ž†‹‹sÓŽRBxÐxGú­ûðþ9n¦)ø0üѰêý¿{;¬#°9¼Æã Ã(F$åó‚JÒt˜òÄ`¿yt!ugp†GCW¶°n¾*ƒ³ð(ëHb€[*{„±<¶¶_ßSËø,I䲆M{4Ü'¥Õ˜ÈÎ]ú¨ Oý›–›=4Þ?êS‚!Y U8­~tH”»*d½ÏÉ„öŸ é ™Ú§%KÚ¡ ùÝ•¡neÂ_:Ò—8ØV ^áÎF=Å/©uV6{)”¦”àÂÔéÚ"=ŒAV GÌ~ó?;4·ožÃŠùÎ u…®‚“+“'éÈ‚¶œ)dSÏ’:®ÒÚœj ¬nMäÎÙÕÑzuù‡fwtV[üc– làebFæÔíÚß9ëÒHÔhö¾F`‰‚ÜF$&w: pŒ¤LJNÕq³+6ÞŸWÿÊ."CƒYMÄ_ÉAÔàÃ!ÞZF”Í•@&®†<þ=Îz– úèg‘:\í0[1j³ô4³ŽB½·C0*‚îÁ*Qw3"Úiþ/|¤<à™½(¡g="†‚ŽÑȽ¼ˆòÎgŒ–È,ÌcìlèŒ~)ÌÅCøëŸ^xõA·ö2d÷æ\—L¹ô ˜¨Ž>ùúè±Ëzd°±ÌgÔYNŽ„a™9]ñêo8KCbRº°É%šq0­<~w¡GFhÿˆD²HȆE‘&4G£©n• ׇ¡V ›ÇPB‰®´-V\GD§°*oc¦4_Þt¦œ6³É_?“ÏøB Âj…ZbLuÛ9qÔüÌÌÎ[¼K<„ˉæ_PaøfCœlM£ùŽ­ö["¥lˆô ”Pé~Â$XÍøž¶ÞQ( ]­Ã9ÏW¨Bçê~¹`ä©üê5ÙNö‡"ÙÙR »¬=õ€J9¢Uâ‰rk%Ÿû²¹]u傾P@ÆeÂìðk6'„ž©}ʙ̔Ã=z9i¯Aùk¤CGÎ9ûjŒ^i ÐKU\£ˆN"’Dž @ÓÊCØol…+Ù…Ö$±üýéDNu5‰>ŒÑVÓ5k ºñ}©z—¦Ñ¿^ã,@êN„T1Z¦é»ÄAM7îW æë¾7dç_@ý\äZFŒ87xJg”)Z£Õ Y•¼û½ \ˆŒra>*øÀ,˜—i2LŠiU•ÿ $`ÝÜà÷ˆ)·p0B„²lÆ”žrU ls®Â¸ ¡%ཀྵõÀÓ’ˆºŸÁÞS Ç›G 8fh71•…&¦"rOô¤:£il4ÿÄ$n>ºÏÉÄ#Y±‘bÐøzÉVÊ;jM埯{V­ÜlL&ͪwÑMžÏzå‘-r5a¸aè3\‹ÕŒµ´E'2Ü*¬Ù¡KƒaÐýª1~Á½ 4†u*Ól;§$.”:˜²­˜-g6{­ß—Är•Ö`êòÑ;SEÛü”o÷{„…:®bBê£>bÀÛÉP™K×FD0Ñ^K5¡ùZcƒŒs§ÒgC³‚BR¬`}†¡ އõ–?VØø…PãQÐËÂ+¿ÌËÙÖ‚¨ÇÊ2%ƒ‰ jPdÊ[¦ÙT{±¬MƒDѧ¹„DÌw ˆáOLxÔÎð\Q~Låh‡®c5œ“mØžÎ/߱܂ÄÓÓaðâ~+ˆéÜæUCØbµ`‰ê²>ÚXTóê‰óÌÁ¹V¹q9žzOÆîJ:7ä5û²Zp¼Žk·|,d9G¯š½ÚN$Tƒµ>ž}aãž7Å5 ÌÅ ù ϵ™ÎYÞü¾zWGûð<`üí˜hr >é„Pcj~ìŠøŸsçyg_zhbÆÙ"­Ì[±œ©\XíÕw”$;6ÁsPC»ŸÈ °çl䲄ÈY/©á•2°-Ãβ\ÓÓPFÃa!j9üñ:*–$xÜDþf»¤-‰X“qÔ¨þ4pL¢@¹»ô¬¦I RQ7×î ëµPüê(pÞN† GÏþ^À•SR(\: ~öƒ…Ö=V#ö\¯¾Jó_ù”V‰<Ð{=DQ5·W< Uý ¿m< Y-rí¥ãTnØ¿ŠOç Lïd`DÊlà(lí˶2¤¿e`5ôªÿš %÷{>ÿÀÆ7¿ $´Â Ѱw¶ïUø69=õº–ÛûïoÂEºSTõó¸Db˜›:DÌâLÐ7G[ÇÉÝÞUÿŸƒ(! A nØc2AZH<ò=`/¹DãGˆði©ÂP.)©Ï¿<ºÕO’·—-v®ÇLõÜÐÆXöi_ùA4ÚˆÌqì w(ÍII´ ÒdìB[JQYo cçv#«Ò&v -W+§oYg ±Þ67V¤2VÜ]¬™Ÿï€°~'úß®´ K{¾ëÈí¤ŒŒ‰ˆÅîÞ·ÐäÏ;§o­‰—:Œ~eîû(C@e…° o«®‚íÜJï®Q¥!h`ßýß¡.8“[‹V#n`øÂ»îä’S¤¾Þ<‚ïÿÔ/c®r·kå2ã`óÉúÈiߨKÞ$DÃ4žª¿$;‘Þ ã%§áÅæ£6ìÕµf¾k0.Ê¥„éÆJé²p†úÕ¢*It9¥˸”Á€ ljñg¯€pÿ<=øŸ¤BN[$Æ·îWmh¢ØâQÂp¥ì0Û Paõ€qUÎ`˜èïˆmeÜ…»obì}=1Ò)±ÀÿV´Y&ŚЪñ¨†¬4UÏ.»Gê°±îóéýí—‹e9£O¬5Ò¶ÐU â¦Iå(`ô ~çîARvJ9Ÿ®ÚßfR[¦zª—[c=ô =»’="w5öxÖúü}²SgpGôƒêŒ—³^:4bñ¯q oã1%(îbIêNœ‘ÞÓÝÇ6©ß9 LN„Џ»Ñ£ŽýÓ|TlPà7œ.“ Ñ‘ ð3Z“BŸ¾¯21¦t°F÷À*NÛÿjMY„&W¬$Ì!Øí¤:a–3K|7O¿>´¹aÉ™Ú ³_R–fK¨×¶~,Âý¶ˆ…|p»Ä8 Ç -U} )ÈMJù XÔ’0wi•^i—TTAÀ’+’_×!"."Æ.‹ nt •ð2H„Ý+y±< ¾¿}›ÚÑ&¤Q*ø4øÏG¹n"våœlúÏT—rxÎn»ß¿†ÄôOsWç/œ/áË×ã6øÝÑíXíÌâ5ZÞAúU^u*|BÀ—Âi¹³Ù™CðoŒVÚ´h@²:­Ÿxìå:Å«3sŮՙ±VZܯÔgdDk BíxP§ï_÷/á[¿&búY ~q/,ÑXëG+0z`[ë[#ÌŽëåÏ’Ü0.³<Ý[íw…7s†V'ªÈÀäz«Žã´ˆÈùFГæG4?ˆœýÄ…é¿àËûprÆO»²0Õůót°vQ( ÃvžáÄ\׉rÓÓ’Ö\–˜å(îùsÄV/®æìêÎ^SšP,,›@øð;ä—¯vCäö}3Ëq:^‘Î""¡º>¾÷8.ê¢ÉÑTñl-÷5@Z8¤š®Â|Íæ>£EÛlg)x gñ—–üç‡â¨þ2scnä^7§nk¤F¤d5œÖû½³]è¶â![¶S13KêƒË¾¢3æ ’¶Sš; Ö™ÐoÑÝð9N•,+ —™_pߨ¹füe(jÔyXNOÉÇGj³œ‹Î¼âññ'~<9ŽŠ—Rº¤|’ž<~Vˆ-ʬy¸Úuó‹6§w_Ö7MÍWßWga7˲na ä¢k•!E[±E»šžsRÁð¼Þ¾`Aî¯BÏù ²úÙo†Ï§ ˆ—/ÇkÓ¨[zš¾´·ŸòDüëlRT2¸ÙX&ÊÎÅÄê·QÚqš òäúö˜+‚ÃùèŠE £(¾Æ—D/ǶÉsD*\£±¯®£Œh,h_QXFųEr=T‚àgÖ×Ò¢^6zt Ò@òK˜°ËSêð^ø(.®¡Áçå™ÍdÀÓPÀ!®C×l‘äÐY Mu®§®.ä°®Ö£[7$YÏàR€»Y|öŽñI‚ Õw<Ezã~œ;°gv"ë‚wà.O»3|6 ²ÂH&P“a´µÒCBªé½G“x)T\áEÄOf$lÌ­òõ…K⤈òœTÔšõYË)> ³0_L;/@Ösx“ÔÕ Í®îÝð‘#A;àeõ€8â¸àã’=Œg;lú„ü™)cp µ<:Iìj¾*Ÿ™¡9¾EÒ5Î_¢ ÷uŸ À;öÚ sõ\3vèþ7U?®ˆ¸ÎÔ41|kæ“÷óm¤tx0¹Àé>:Ö!ÞP¦¦M Œ2O1NÜŽ^D ³c¤hl‘"±â íê³fý?ܨ×TÉ{9FÛ]âcã}†Ò£PÂdv,™ Sn„o©¬9‡ [)Ñ$릯^8XQ»„uYœ&ÓÑ>¼ ©ú »Ñé ,\-‘«¦cúšŠÞ™ëLÝô&1|,µõP•±ê䫱-åô²G…nÝ0l²jI+„ýŸ(WÆØm¤6 ¹W¿Àá2†Î Ö¼ŽËH8¤;YÝâÅ¥Nc#ñ žx2¶ÏëÅW]!ÄñÓCÝ>¡#‘e ¦VõQæj35YÌëÈ4©ÁÖß]Ô­ ëFúráÊ+ô¨ÇaĹf‘…F 㬠׿³+_>ˆé—S£P ñrœÙ“÷3où?Î0oþï'Dý<6V&f •mÏ„_nÔ%Bß§´±*Q‰8É/‘±÷m¦7’¿§´C¼¶t]kh~ ÎY#°çÔ—ÔØÇu#Ž… €dž,•ƒ¹÷&g“3qƒ,›$õû 2å3ð7iqKÁúÈßxn“ðœ|N˜ÌO¶–g“šý¬Û6þÛ-H騅 T­kÝ4¿‰=9)#áqfwýîß)uNÅ{ Ê=ÓØÉÒsĽl@Ã7&„7zÅîèþäWÙ…éî221œJ>…†«†Óý§ëcÞ2̸ـI] «[ì¸~¾AŒ‘'»>~|Ä-Oúµœ¾†ïƒÞÂÁçÉ|¹Ë‚”Úž{Ê’*â|mÿe{†!ñ<„ø‘­šÉË]ýÜ•¸úÆœ¿yÉ<¬q'h@3 ävr6Ù 3È—/†Lƒ™YVCí8”ZáaÁMnµ<Ù7“+rz•ÝEIÒ܉XS€;ýÕvGáLãµã47b¯DŒ7ÀmâUÅ0´†?1ƒ€:ŠiYl¹¸luÑyþ® EªH =ï?ÞîÚ‹x;K–[ˆ ÞTD(QÀÏ="É~Š\hد–l HÜÓÔ{•³ –e¥ù;‰£æ•?* š1¤P!±?5Œ¶½8cz2ƒ«ðCˆšãögICO‹ƒÈë­.ì«Å&40 €™éaI7Ú`ç›òpvÜI“yò%ÑV“–ÃçPC'÷Xañ\«<ü˜úä?G.q§4jO’Ä™¹Ï½áýB}8_ °|\ò·š¾%sù–µ΀Nn6¼ÃåÔYýåF!Øø®vµ!§×f°³`{9câGëJ^¢kq"þ”Æ{õ-¡¡½•?ÕOõ!Ç‹}=ØùZëdLO8®s½æïIZ8—k!³0 êޮƮ\,æ×XlDz­A4œÿŠ"·ÂKòw|¶;oûH–‘îs¤P4)G«Êã¦hÔ4n{5¹EŠ_\@° Ã½*h7ë}ôƒ•« ÈNþ!l“l ‡ 2„̯5?OÀmÊ8¿\e.sù(ð*q¯¼4R+qÃ!o‡\mù&}9*Zˆ#× B*ý&94\M ¸d ÃÁˆ¦?d )¿0Q—l¤e:ß ·QþZO S&fe^§jž\ðc/ÓÜýrµ<4,b|ü¦ ©¸„=AQN ¨ø˜2ŒØÌô‚PÝ"‘¾Ã-Õ€× AÕÖ:‹¹ÕšÂJ4—nõÓ"¤Õ&»P´Qŋì6§]”?ucïÔ^rNôï_Õѯ­c=€X ¤0dÀ¨ð~.rµZöì7w‡UºBš [€! FqéóŒùüfŸ“±o☎<ÖWDÆ í\/aB÷;(Vš7µnvîz«ñáÁãd2— 8ù•Ô7­I±òWs߆)ÂiÓ$7 Âû‡fgǪýMÊÊ6Þ_Ýiß±Ê}cP§í("ÜÄ"ñ¡ÕDáA×l? 4¹ÍÓ|]í+à)áË]àcuÈQÚ§ŒA_ž¬DçìÜö×~¢‚ÓQ¾§Ÿ™\™ÕK l«Å#°ÔX’Dvt}ù”X¢¬µÐà%Uä'dXKK¯,Ö(½.L‚eôûªÄí_˜ù<Ì[ ¾ÌöâýNëCÓZxq¡n™§DV lŠçØ$Q4TòÈ„Gyû¡!´>¹ÅÆtAŒî§ˆØœñ°tß"Û¼e†v¯³Ù]Òíåôj̔¬òÌ-ø(¤ÝÇ/Cw)Iüþä²ÃL1ýL•¥®K=Ô.1)Tá¶o„83IŸôq6Ç#5ïœP—´€«€ÞЈñVuX{ü/)¿dÛð“Ý/àÚõu!^¥Œ¡Ëg güÉÏl•LüšïQªZH²t‹°ìIØ×É%û¢¡g{7 Éhj„ô#*/ÝRÆ­Ü)}¿²@œ/ìëTÄÞÁÃÏ. íŠ+iz‘]k;0¹mA+~1CqxŒìx=yß_³¬8éFZÚê.#I+è_bKÏë«£…ÀžÂZ§ñ)ñ;Uš1&d:¡ØßW;¯kÁÕ®Áž4l®kšƒawg_‹\®²ˆ²Áí1þ$}(Õ£™ï'ÿBGŽÈæ†Â‘™ ©%kM,¾Ý³îùp"*›yûr’Té†ë%…º_‡3zÚÛ…×5µM[\ï÷M{a ÜMÜIRÉ ”óŠ#©£o^ÎéÜ*+ôb@“]äláëšai´Ù“•§2Öc«Î²¯$0˜Âž?öãìZÇo;^HuÑw.—ɇú˫Сtòj" æ(-å ¥'Q ¢îqȪawdÒ¦­³„A;&²8;6…sA^3¤D\Ñ·´Îûƒ©¯èöh÷U$özó¸Å#ßô›·*/âf•M×õCÌ<Å_mýV+‘Ї!ìôžÊ5âÙ7~#V{­«=ãsC’ ñ àœuLHc3ÇËüíWj/rK<ò÷½ê‘Ù§Tš=#¨Jã¶èxïâ53Ö]ɲcÅ]÷»Ä¥÷ˆiÛK/‘L;ÅTÊ7.ZÝ:¦Lð>z#¡ª?ƇJ½b<7b›´Æ?ö°U\ëF d[–2ø]ÐzYÌ ˆåRË gø‹ÂlW°W0öŸ~„2&ñ¡ø?äHæë‰†>D÷èhY&T…M°ÚNô›ºk± \QOUaz¤!sí+ÕÏmkßÊÔ%õ~éÆ×Ò¾›ÆNÜ©sZ+,˜µ˜Û =ûQß•ûÀ´\¼Y{ã6ÖÕ9‘y*[F¸ùfè²ÄDµ4áH÷ÏðÑ `J'¨9HvJ¿ûû*Ƀ¢aà~`zÿçýzÇOãÔrÐåi¯¥‡ D³î8™3^I%_ƒ?å¬hFE××½=ÔÜGeÇ I oO÷9Òø<*ƒå„Ý;KuqØÜ]¼ÆPàjø«Q ±€®è ¢(Íǯ ÏaD*ÝÄÂÃ+™õOÓOØzú8UÐE#eô€kI„u:G]Ï^›º¦¸—ä™õbá×è…ãÈ–O×€<Qò^ãÇ“²{úKÿ…ráïIŒX8•åñ¡ÿ" Ž¡‚ðù”õ´Qþñܱ±Æ,çZÛy7ñêÕfPb@èÀ-MÃacxL/ŸÜ¿ B.[ +fPa²ÿ5¤ì›ºcD<¦ãzø¸5^ÒK"†>½ŒvéðL÷ÖƒŠšƒ›Ìkœ>ÕxÓÎstx0q¿æÛ(IÆß8™Ô¦6GšmU‡õUÐÓoÃîhCn|^-4ŸXFÝ&,ŽÚ9‚ù7J¼CðŒ€~þ´°i …-÷rrG¹“t"|ÏSõ©v#ó,3é°Dt¾8±2/˜¥Çës·«ægÒ(ˆÏ–p~P\+Ù"óÃ|O,ìûÜÚ<ÿžT»Úï—¾ËÞÔé‰ú¡îr’ß®ž£¾ys7`íÚôs6r–°g§…4YÕžö¡U6_™w?Àõ÷;ÌŠDu÷7Æ Þñ¥Ôf,n!¢Åà0êØîþ µØöÏ“³ˆ`¡îüº+·ä=7CWK£®nÑÑG,N±ÿ0úŠwÔpK\3\wÖN“eºñ Ð=šEç hù ÊØ×Hv B½‡Ò‰ß§ ¦3y¨M¡^ãcšNá¬y3× õÍ]  ]³mQWÓ…0m7 '²é)6¶™:æ_Ū* \ÔU7÷´B=ªá:~ËÑ¿˜®Þâ(5®…íóãnEHUkÇzóæñ¸ ñ×2Öw 3IvD hþc)(~ZjBÔS"[°ÂxžžêùÊ´½¶ FÚ?õåaáwì)±–2PsòΓQû“ÆîPçm>ôUÅ.÷ÿT“7«aƒ –G(rÖ0Š>JXþóÁ¿¯Þ«!üÝ,Âö= Cò¡) ÚgÉ»ÂɃOš èáÖ¦ÇGS†Žn ìë\{¿353Bù°L% ±Nð#(Ûýn°Pæ)RrjßèòKäkC>Of4ÛuUõ]€’¶N¨¥NŠa¥§ÂÂùcõM"“cc›4Y{”Í/ûF6Žî¬µî mßö'‰HfâAÀ¡3#—\ж3l™yÕŠ|J™b©<¦yq?)E!oý½TîSƒß…}3Æ®öÐdQÆØÀJZh_N1hÔÔDM RÀåÉÂüy¦ ŠàÕZ$²Û׌€Èî‹|p܆ñb´“hî!ã ÔékâÝö¯Èp#é?ËmKÄH×àVA%Y Ø<Þ1fZ:DÑÔ™†Lk‡Ñà A“CŠ²î ©àœ±”®m‹\Ü¥|k¾cä5ua[ìÑ;u1ô¾PùpºÖDÙ‚½ûœŸuˆad¿q]°€~òü.ØLˆ7žÍŒ~ƒjÅ(=[ÚÐÈ¢a:þ°A¹è@¦çÃ'ï•S²'–Wkn•+&œÁ²}’,ÙÀ†i ÏPÎVà®KbÒîsFD (G‰Ãt†˜C €ñV7ÿýcúì¶­äô/(mqïiO™'H¤¼»n™K ¬„Bº‘"ˆÀ0dßôMÿT5UZôÈ®Ž%Rìþ­?×ÄõÐÃñÖ²þŒHÔ’ñ#¯³–Ìö¬*(¨?>+€>¤”•q¼\©Ãiãh¢søÔ2gxC”4¡Á:î7Mô@ˆ•xªoÂJˆ¯{ìCRÜçÈíÑWªP%zMŸLBñ\¿t²-rj7½Uw­ôk‰?żxõw„üXÙBžùÅQ¬ÂŽïgc{¦g«‹a€­­{AÖPÊ ][”µ¼÷oí÷ UrúäÎu?êmtb– ,lÐ¨ÂØÝu=_•@ %¡yaA<%™á¯Øý§x506ö±DFÆ—½¥îµYtD1 •ܪg5 9v8STÏ7êçÆÜ‚“=( ²O7M²› ¶ÂŠ–)söüøÏÂS¿Èôî„U‘«Áœs7!¼‹"?1Ï9¸G±ÆG?dµ~¬Z–%¾É2¶e?4wTNÅ™³X4WÀOþh5äÊóqÛW8„õôNA9-’¹ë‚óƒt8¥mëbŒÒE †…>rV‰O÷ó«4·ŽKFlcz2yõúž7z–0Ïó -¿QJ ˆ>¯™™æÞ(äᎠÍJܽ‘«x]'׉‘ÖWœò…n>³òNPÿEëçÜ}¤pÄ–l…®KïS0Çð–Ûï|ñŒáì†ýŽÓHd¥íké¿Jt–ãíCéG_œ²j¿N-¯èq{{qg=þ3¥e͆d=½Ž¼äîWKùêÙ<®Áõ­êÁlo‰ÙD¾XÎÐßÓKç%†ºGiußÎtÎ/ŸãOVä>ÐC­âw†Ø»€ØGKU5zˆúÙ×öô.îLWàCØyã¸>çedy—4žÜa_[õ€ô*Û˜´ŠÍO³þ)_ÚexqùøWW¨NFWºËæÎõ…ߘ‡<Ðw}’ª¸žCvT,V©_îg¿5:1+–nät2! ò% ©â[Š”¼n_ù»ª'°Ø fšì@ÿ+×ϼEj-¾Øôáá(;,BíGu7fˆÃÜCGwÁÓµj ðÙÇû´|‡ìŸkªH]±vùDZkl¯»L;·˜«ýᦺå¤ÃÃ,¬k$Œ°Òq¶½ùÚ \Ã"˜ÑxièÝm×Ñ kóÚñƒ»®NND={áfБ¡þkÌrªäNvOYuáP`gA~I¦gËsK°=G\v¬¡@çò·^€yà“×Ý ò׆LsÝE‹ cÖ´øm¶'•x»%ä0JŒ ƒý©s7Øï¸ùбEÙÌÅÈ•Öb6í{§þ/,½žù]õ °±õI4›5sžº‰Õv“¥òÙH~ ”FØãŒOå1 ¦TƒÝ—ÚçÌ,²çæcënevB€+&­¾6Q€¨1-8¦KÌ`hŸß†ó”É#ÍßøVÿg5nç«ø¶%H3¨´€‚‘ EP)ÛSωhKåó‰øÜE®f#šÓÞF#Á2Õ}Ss0  Ô¡ÜÚ­f‹ Í—Ø*7„)¤W2ëÞÛÄ=ùiª½ÙÒ†2zŽú¢ì$xV¢#Øœ)©Î0¦ ¡yÓõæJ‹r^Uhwìwéõ‡‰Ý†*Ñ“‘E5 B7#‘{*hLK«â.¡›sêBÒ¬R„:{"ì"Å@Ê`•~™„Sce£¤”âkH˜4øŽOøÎu‚²³}{Óª¬0Áì­ã÷37suŽ8ÏTmI­u£|K¬õÎq@(å÷ø«çL·vhSS¹( m„”Ë<Â6ÔƒsêÍj€ ê™øó:Ó\HSw'Ò €LÅšP xx:kÊÞŒ IëI×X«)3NéKæþ͹šêu‚ÞÓ»öÅ/׿pz*v¿¢­Ût-;Ü+8«£¯lÐÀ´I êÜV # P4€“|ý( s Ú†?õÓQviÜÓ€òD ×ÀÌDfvÞ#iE~íÂñò/:Ärö¸ NƒöW¡¥W º®¹…·8±Fän—~.òç¹6iÃ|&/ûôtÔÉ—³ó\pòæŸ6Ût#µE+÷Ÿ°ø¤€ö"óMŠL¶è'r2 ¢v•ʧ»³¹ Éd_ö)â> ½x°ªË¥„à31Ù„]äÔKn¬‚ÝYxÐo[VÕ7ÚØ‡]†þ/vÐ[‹»–ÀTšï7aü ª¦$"Oª (6ب¥ŽIÂ…¯ë:èìj~¯§TVzõ®Ñ¤™^ÑØlÞK~Dô¶!Ëkr“¡ÿŸ«â¾‹°#°ÒÖX*ûJ§ó÷Ä9Éb¬,uñZüÒƒQJ¤¥v«˜.xa ÏØáy × “ß8ƒÚeÑž_õ¦õô£X±AÀ>H;".u;‘ èW…ÌŠ«àÏ.)e–¥iœgŽê5tN_’X`wÍ.6Uôw»=È©+l]Qã'¾sæz*ygÄB‡JìvolÚgqÜòÚS ¡Gá6lR%èxž¹úÁMÄÈbf6wŽA3Ÿ"ùéoŒí5hû;?—:õ¢ÍqŸ‚e%ÓÐ|!xÌÿ’õ0÷¢˜l^à9+Š¢—Í¢¢ˆ ã¬ù[“Æ”üü±~p_¾ØaYp‡ãjE GŠPzÔ'²`vd,~Ĭ4mÉÉiðCdQ©+ @wC&æ¼l~ÒG Pa’N°Á~kªôo´ {…³'ˆG«@ÑXožô³³"u@Öש¹“wTjøñûùȃûh¡JB>˜Uz¨J?úd‰[³&õ¼“Qa:Œˆ·ÿÖ&“–œ¹å*Jß@ ÂÛ€ ?Âä‹é½Ïúæý´Ì©ÈX¿³¿Ê52cjXUö#"*œº*™Wý·&q‘`f~¡ŒÃ’Ûê‹0Îã^úAþ}š«¿FÉåz4à\XÂëßÎú…Báîzý‰*eê’¡BܬÎ6sËÝimÉ"}~ŸÐ~U&ìeÓÆ¼Ñîáµç´[ùÒÆsº¨†DU¡µïFpOè6Ï`+(Td½Fͳ;s¬É&n€†‹{”]ájÜ-O~kÇÐ1ÊÓ$@j%Õ²øAõ”$;SY/˜j“¦Ò&.úœFûSd"õÌâk¥‡0ë€i±~ÔçHøg5üãqÞð'j sþøŽ`…<«mÑBº'žÐc($4§‹'0X$Âú,H0(~È¥ 0¡×D„0Ë®Êí\ˆk$»—¾x:}°¿ô!û¼åÉhvÛ©zu-¹v.à}Vít>Oö%ÿCbµVGOÑ8¼Ò¹†Ãй½1•›‡¦ÆŠÂðÝà³PÛ{°ÖŸDeh±&ÕÛ_JzÕ{ÜÄ £ojÚšþÅÖ¾«Æ¦!ï& \g¹ç«Ù¨LïÒÿ'ÀÞ\š¨#N©f£4Yõ»éÊÃëõÔÍ¡:ﯚ2äL‡±üäV)Ô™ñû¥Át —› IÜ&(×Wq'û_3³ô”b}¼X;CUp†Yu-Ú»˜xШ1[)sSCC’S35ôÊí®Ž´_e*•°‚Z£é—ÿ$pÀ—î¿ä6(nìšKœÛ­Ÿâ*ú\LÏhP­àžyïŽYA¶$Ë¢_eíbÖëž-•[1Œy«e¤ ¦&l €øèVµfÒ”}ë=(Àß“"F`$.«ž‘2¬èZFÎøTóvè‰&€ˆøóÇ ­ùLÖvÌÊêÕfÞtBfDñ§¨Ø¬Ú½7öªd½e.ôw¼34ZpÅ«8@Ô¯^›,1Å·sdSâñ·Àz:ä{×DÑŒD LWÊ=3øD†Ž=ü=¹•1X„ó!2ÏŽ£ñ=<)H½âØ yÊìFHväòîèÄ9‡YAPMÅgÑV<‘¹¶)<'±ÌîÙaä Aøoɲª[Z5~a£Ó<áé^¨ºS™#hk7>Aø)ÔÑ„¼Ácmn¦{ù){®0_g(»·ÞM.ýÌ`"­ƒ¤60åÑäÊz Ï¡›á%þÏ?MybÓ9œÎ.9¬p-³aU8>¡IÁ˜‡Ëa DÌÜ,W­ Ãäš,dO´ŸÖoÂ0xQ.¶‚]ÓLw _.PË}7”lôÛš¢òÏ Nè·}K${Ÿ+1V*‹“,¨Ñ˘ÒÅú!ô^$¼nžOæá«£Ÿ¯edIt\”7‡/à8.ßÎ5þ{E„ }ðÿ„áÌsäb²=æB–PEtýógóSã&ë!óaÖæz¢¯÷L/׋‘Žl¼K,IÔEéA•Zˆ¨<´ÕÑ7Á¼ã•÷¶ßŠÖåÔ?š§Ðª¾mÁã­ctdµ}Í“ÑkòŒ½fç<$­}UÅ Ð é¼À„QÒ4-ä¥åÛ@æ¾iiŠêéYeƒ\z;Ò5»(WG,ý‘‚í–iORQ ™Gïí\¢µ¾,J[=ϯˆØ šÓÅv\–nÜ*BXê²öpwu½y¿xGUíß_M¸ÁŠÕÿ–Dê\På3²ñ3bÎç–|Ȭժå¾Ïè€Fòl/Š‘Z‹por.“ðÀöÃ署nö"ÌÌèvñS¢~ð[‚HØ“Ø «¡ã-U)ör²º)1Çj¸c¯Éç:lYe®^ó."ÌH¼}ðì“és_ =>6É Tð¶y^ïDÁëadåc¬“¬ÞŸR8³OŠ~Sy'“m\{Úc–¥œÝöˆ¬â—–™šu¶¾³4RQ5h²Wš‡ÞôÆ®›ò–¦Y6{«WZ#‡"…|l´Ë›Q+²˜(-åÀ»E<ñÆ<„ß{Ù!kÿ1„?¾å2ËUñüi§ g¡àB•b¨ì>(åqüBáM_ÇT䎹=éÔjº]-ªSxco3üИ™!ožÑ¼Jô†øE‚Zˆ¯ ŒÂ*ãÿ •ó xqÎý~ÿ™¥‚Á4Š#¶R¨êÓ#“pNiXú¬o ²bXeÒm+ìOÒ}‹ÜSu®T2›]“åüJ p"·ûžPçøœÒŠÞ]úšÀçfzþÌAm+ååô¥Ï2—ÖØRÛ°îõ´Ù-Ìφ Ž=bZ‡CÉ»®Â[ò Êet~틊vù^|p_¥ + hÍ vY´[“—,M?åJÿ6nteôùýMу¼èH°³|T3x© “¾ÞõtòšŸ³1kÊ8ÂS¢ ¹"Ч,Ëy>–R¯\%7u[†íþ¶ª5éÿí bžYˆõpÿ]îÏü‘š¶õðH±Qnuø‰ªï¬®*wê‚ôõRaÞºe÷ÎÎ¦¹´IHR/ {gêáCþ ÛÌÞó›Aì±Çè.ÇŽ¬Yxùï‹ö0û{•ç 54v:àãê³£Â#\™YAêÆ¯á¿ê¡™!*ÒÅ÷`ˆŽÅ$i¸ô|\Ãð( FžÈ¤ÛEº¾Ôå:á]Ÿì®Î„8_ãÌ ú è|—Óî‚Lu_u¸Ò’¸´{ÕRlÌ ½íÜ>ƒ“ýƒ(-Ø[È:M¾ÙšÑúl9Uwv¹·ça÷KÎO¾›‰Ø·A!ÛjK «»+K®“ áÁ*ôµ²87å#£¿Ç™hÔ™ÅðC\q,Âþ8é­¤ÖãkµB*ÚÝúHI™sžc}ø[šsÕ ën&iŽMgL¸Hbtc1VQp‘%¹a7kV(bAÜØó(ØÀp¯ÿý”iÓâ‹'o2 -ßsTF·&WÝPCãÇi‹ Pü‚îL¦©ˆwÍÞþªS„\$àøØcBñ*w"¡þN ïUˆv?oe›ZHš¸ø7[pƒ€<ª>÷å(VI 7yÅ&ß.3|åàÿHµ<"k¾|ÏaK|ˆÎï8Ä‚#ókÍÝŠî[Í¢TÕ» ›Ù®*C™O {¨|Öìï N5tóÎ8ç¤ÂÒÕêî쬚H¯¿T ˆµ§½ÚLXa1†1ÔÄÍ?ì,_ª™1{¤DñÐËKV/bMç8çÝlF¹\ŠÚÕ=À3ô`Ãÿ N™ó3Ÿì-¹Àx·KÆ'ôÃÌ$ÊÂPÀ&1®æZH &—‰co„£Bøo>+F¥ùÜÙIp‚` ÓÞÜó¶³L©X ™S7}ÊÍ·Os˜ªö Õ5p1¹eî䌰Õùð}‡“ŸNŒj™˜˜W¯p½÷ÛŠç‘ÃûªãôeÌÿ9£Â—`Æ’›jJ31ßRöîƒ×±}(:ü ¾ûÈaf~­{.æ^Ÿ»½2‚ ¸â®U¹-âæ»›x¾5Žðp’Y§x½\?уÊÒ‘'ü¢»S›óëD¶}¢ÙŽiÄšÚ7=zz}$Z A/îͲk†Ú̉•Qþ=¼Ô)/ ìDùÉ÷foÊêc>ï¡ Ÿr™î9¶[™Xz/t'fu“±âe{°[ì.?~ £¨;ÉÒ5b%j‡Q}nûŠê?Aãq'ààr¾Š×é$ĉZéLÆÂ]MäÁ,½ë­GI…|à— ?«R}#‡}5C M#°€AV Üýš…ü7Zã’,Ž<ö|$~C~Á¨€0¯ªpEŽ0(3nc7KêùÛ#$/Z¾ì?š[ô%Y†òT‚бŸmÊš7’½Ê oŠÏÖ—ú¨bV-7o›Ö\èpŒGö\‚Ì5“5Ãýß“û®*²:Ý™XmAC“VKƨ™øjÊÈ_¦ƒ¾òfŽJï~²ÿ<ÓN÷»·Ðiã ò–•0J¨Wƒ-öïó¥ý°¼Ó¤6uµú÷§ m¬þk·[4ÿÁ+‘IhLæúbrŸÞ g­¯þ¨ݮ؉5Ûö7ö.ƒš^º‚`ËÚ¬íê«/Ó—0Õv']Z ×€®Æþm^½1#8AQ%¯Û/DIøQH›ði:>9ý Ê]0 l7J÷i˜ì¿§^4¹ó0O›½>l>Ò1™b¿brÂU„俉PÇÙÞÒwßÌ&¢’Ø1°¬²¦Þ>·®èÞ(ÁñΗjŒ[@’}8Æ86˜éò#8pLÁÇP‘µwZ‚o'aSHçg§^—»†áãz̽ZõËÁ¦î¯’3Ä$J ìDµžc~6ó[º~*÷@Ö/?qÄ "ï[‡—3¬9™ƒ/㺄xK!@BІ  ¸ñGœÖn©«æ|¸¯Z­%™0Ô+qZ>_îàMÏkÕ írŸ{-Â.C 8:žsÇZ›¡Â‡¢JÇ·9,ïe|ÆD ¶Éim6ÐZS%²’Àºã‡]EžPU!kø„±“»¾g”ï~ÅIú£ºwÈBÏr Ѭ¯B­ä!”Ý„èíå™"4ÄàÁûM–¿«À>«TÁ¡vôËL³§ëɵ™J-ÒÝü.N&HTúÑMâÉW2~ÐM^˜\r?kB¾7ÌBõ…9Ô¨òhëÍK)¬w×›4¥PòQua¢ ŸOët&`NÎí+feäËÄ»ÓQÒxßù«éˆ…nñ/r H©nFëª#ñüË¿k9÷³¤MðЇãßöW›&Ñâ¦YÁ2Þ¹>Êá\ë–ÌÕ-7ÅÖµùÕª•œdéÈ”<Ëùö,îúÁXžó…ÿIØMw-:ݾZåü÷®#vå ÞÁ×LúÏ–/ÂT?µR‘ ²l+ç\áœ/†¿‹B.Ë7¾L—x¨ç¦¨;„„ÞÓ&§È:…îjÈ&’ ×ðò?WFÆÒ…Nâ…YÄãŠb¢.“š©UEV2t‰ffÀ*.kÁyn Ýg’Ôž‹ÓæÉöV5C9ÜGb²âÁÒ;e9½ðµ†(‹¼k$v¡Ÿn|ßÌǶ^tM½—¯Àoq:4c@èñG'È5ˆ[£Ì–X2º) —ó=3Ê{1hÊD½ZÐ_§ƒÕ=†Ð½P¾Å·ÈYÉ4â£VKµåЗôÈÝ8©ñ"a‰Nóx²hà‹w6§˜Ýù¨s‰½RµQ-b§÷©l.éb†EϹ"†¯ØYõ]¿&Df}®¥ô\e‡ܼJÖ%N$Ná@3i™kO2[yÝÂq̈¯îgËpo79 S¿ŽÖ´ñ¨îV7Qž³ÊóåÄ’ÆMI±Ô Š"ƒ-µÇa.3GpŸñÓ^6#¹yñ¯·sßEåSFuöÛbéë2$eï„:;6KàMbdÏQ^…èï+=™h~TêÁDD fâÛš%ÝÔ¬Ìä–TaF@€q]ý&R3¿‰¶x [ìg L­2!¬ êSwjNgóò#Òu½YÐÿ®†d·ö·Ì÷Ïçç-L¿¯3V…Ö:‰ŠmšüÇÖèå|"{v ¢¦¥מ¼í¯W”‹Ðàtþîc¿ö5Õ7jÒ¼ ܚ̚+ÛIœ„]=©e.ħuŒbÄ‚º‰JݶÊÕDG)¯ƒ‘gNòv‹4IÞåY—GÇ}$´R"¬ ùó™ñ 9zó•|Æã¬bGM a•‚6H#’vë*nrd®îÍF‚–3ÁxæuœÁRžxÕÎVòð N*n ¹Rt³«ãp~6z.ß‚Á.¡CI;5\Aæ4&H×UáØ(jü¯š²jÉD\ ±8ÀÖ}ô–ÛÆ©TJ1AHJF£ûFZV…PÞãƒF2n+åÎAnÜÈÊ×`ŵúÃM½ÈÊã{%³[™§¶6ß#…)æ¡ÊÏîn¶{zP»±ŸDCùg%rÿšÃÑpÂø‹˜µåQzü¼¬)»/uô¤8:Ƭx!,š“O–Ú;Œ‡îô^ÞÔ8çA;xÚO‹  ’Ïš—˜]–ÆΙåûA¿xq«UFg×µòŒh‰ ´ Ú m½+> &  ’"ùw»ÌI¨QwƒãÎÎÖ šå2O|8rˆ¸ê™¾NÚ$<Ôaëç~çÊÅJÔ¿¸ò¥.Ðyâ×£ñ™™”ÂË}ýþc~ð^ó–x Ê™90?ãÒ<ØÙwr•¤wb0½¡­™{ûï¸zó“ˆÌÀ¼´˜ å@‡:ÇšÆ\¦N5žRP5­ô·Q—š-'ªT8GåâžoßD}€¯Œq;€`S*-}‡?J¡€W'C޽õEº29 [Sž^Cu×É÷¨°8ɯ˜ÿw*þ„kì­ÙÇ“Lü³^ Ié|?R¹#ÍzeHª™S²B²ÞN÷ÚØZð6‰k5o„€½‚˜C¸ì9/FÑ5ò(À¶LuIh¢𨧠ÔÚážÌò§*ÿ¼NñY™Ý(‰žÔvuë%uç°ÚÆ ä_C£Ö(ÇE€ä$—ÊXõÝ| РH›Éwy,å.ô¸:°ó;]^Yx¡[J ö;á§Ùy[®ÐصºG¨Qh ëîÙßu`hžåPŸíËòþÝÿ^Ú¦X"àb“”ÞÅX³Ì²íSµf.=JÚ<< _/øï²ø'J÷ßù÷g°(Ü´M\ÜQ«fÌJ΂W¦yX”»h VžÓ-*?)>R`/6…Ý=°€ài‚èO³Ñ9æ_—Ÿ–4ë›+‡ç¢ ÌÉk•8ÂC;ΗÛ¨ŽÓœƒÍˆOzÊÆ¶º¾¤bÿv2·Ãƒ"†–$X­Ü7å¨ÕØ­Uß šØ5™÷@‚¿¶à¼w6¨Åäþ„á­ZˆÆÃÞ‡YŠÂ竳{y€ô2^,ò\º˜¯YêXhò¿•üÈ…?aºªögìY'ËÐÝCÇF Fˆm´@#³Ïûð·¦Áäî[ƒŠË´ü5yëñšpþïTÓ™ }+À3\¬o¤Èb×L3F©=ÀÎU¹ÑAIYaY]¯Kí¼ð?y(©V±ÒÝ3–‰I}ì;+‘ûG1U+2’îØƒŸ˜ùì„cÕHº=¦Æ,™/| i“üuem?i¢ÂñŠíCÈë猞¾Úâú`=|àlîtÜ7R 7ɦƒР‰-„ø£­úñö1ØêL‰í‡Å<ßcbü3Š «“FI» ®t5§–`²ûâ›4 äM(Nßh°ž,¥rŒès´˜;!‹N´…åiŸ:A™Áó˜ År¾ŒŒTE³Ë o"Øbs3yØÒ3üH¼øͬ ¥“h»—€ ùòíí ð°)ÉË[wXI±ªù8 ~µ ¿…&dÚknnÄp³åÂOýs"<à9A§¤Äàõx8 U¿‡ã iÎ$¿¢v·q’a>á~?ŸEkÍóFwððyd7¶òÓÚ&p‘G Lïzû:Nƒ‹Øì#žN$Y5û“Ê3µY»5Ê&$HrîµmºRà¨û „©Ö•Ë®dWðÿX%e¢õ M^S­ø°>ä÷çÆÇXÆÁ‚!£¾m;»*3”²ëM+ûï‡ýSj–àA¯¸/Â>D–🞺 ¼a…Eæ©H}jÿÇ@º4JúèîÒR_êîgs·ÌÉÃbb÷»ÎéRæ»]°<£õgu‘Zs‹d[qí|$Ãp°Ñ òjO( øË_3ó•$dEˆ×e«9p F·~ ”»ÆøxâeCº! "œ…ŸýÀZZ§³­}H™ôX-iâ?B?A|x2#GHrÓŒ m ŽóìÛ”Qî(è@=x¤Gnÿ½ª!Z!l Ðᘿ’i"[{hGÎQ"Ùé­òKVÈÃQ¿ÙD^´ þÄôÿ²Rr D”–-Oxß§ 1uvUÙ2WîÚéœ)o¦v²ù¬†ÁÅà‡ÇCzÓ›º<Ž¥*’`í¯7º¥džð:<-Ï~ZPzÇõ†Šë8löJ_‰k–KÃZVG÷9¿³JçÌ«óÃoê‰Ç xk¤®’¸R†>ùûëkNu¦:4ÛO}‡Â­:%„‘Ju†áJ°ñÜgéVR!†oÐJw"«»ÂÐb“ØêÌ!gÞ©.~Næ?^£ÊXu9k²ñ òÀ™æMìËSêâÎLñ­úÆ¥‚z7>Ž:À,twÂDç!_Ý€ë AÇ ßÄúIÙûÂÖʃKÂhs\>+”1P¿‚Ç*çÕ†›“çÉé þN±t7¦çŽðß;CèÕóY7` ‹Ù×ÎK¾MŸ”-ÏZ°òÆ¡v˜ªÿþ†ôWhµ4¢ï“U½²À9 ûÁT‰Š R÷lÖ«¢Ò@EÜuzåz„+›Y ª,ŒÖÕÄ#QÔ¶æ» ´»õe¼µˆæì£–ÚµZ¿ø¼mÅ«N6”p§>Öû½@q´ÉÛN ĤÐYdpôa*–'=º,ž…Ë2îËv±z?Ÿ°Ñ¶Üøªì2å@#épª0„äÂo>8ÖÕ¢å4u~ÞGd´´kÞrÞømÙÌ›]5 ‡ú—ø ^Òù ÃG³T´+,‡¹©í! 5^ª#¯r<¯»Ѧƒ‘Pª-žÙ ¹bµØÏ`ø¶£©X8æüÅ‘êx¦Ë cB(Ó+PšìZÆó}óAGeM¸îs]ÓyîÙlá8q­©NÅöÁ±ì,Bvk˜†æÎ#“Ë©â„ÜÜà´ƒßL3Xä®2*ÑôŸÍ¬ùmXr_Xd è ¾´<–àZ˜ð¨Š¼ ß8CðÄ¡1þ³ÅQvb”|+Užßj£X¼YËX+SFó¥G/.'\¯7ÑÚór¡ S+åÇ©3L’¼EäyÕêW¾ahT“u°÷Ç'î|:*f5‘öÝï½ø_ŸFIgÓDgüãÖÔÅ@lz‹ü”F/Í(~"uŽÓ¤öÿf2G³Å®Þžžè,&ñ$e`mDÊí¿ÕL'–¡îKSÀ…ÙëòGñè¯D¡ìˆ6Å46§˜ýDWk€,®Ÿ¢µzyÇÖe}¬;z`Ž@‚¼ÖjL„EðÎÝ¿ö¸4}\± Ë\ÞW·Å7ɳnQÖ L–õat@ú­©>óc>©©Èrð;òÃS›ÓÓ=ëÍ®¶°‘K ž2è|·:¦%ŠB¡6òI%ˆüÙwöñÜ1À©ÕDïn[ËŠ'ÉVW»È]@qwJlpʦW^uriJ©ÛWŽ.%ÏóŽ¥:éûo!±ÃfÄŽº?¯Ê $6{Û®Ê΃‚5’AüÅf–æà‘Æ¥®h#f:;¦8®õØ]Mœo°!@KSR¦åBuC<`õ¯r'˜¾ò8 «P¸ÖÃñùß½‹O¢&rÍ×Gdš%×âÚÍ9P¢ µ[á»ÓÕoBr+çpŸ†Im_kVŒ/FN?½Ònp'K­Xi½ÐºôFÒùŠxoÂGiJ÷ˆÄÀ¾¿ýƒ–c-2ª*ö¸qÙŠW^4·“ÏuƒX-Uùm’ÿ*oÁ,ó¸¸ÿs,>Ž6­ 1:\µÒÂþ°ïzéF¦qÒô¼ è…ˆ'JuÒíÍù˜JŸ ¹‰ÎÔù 06¨qž¢ÿåãËrsÑú7åÉúˆ o²ŒÐ¸=úhä’ù= ÛˆŸ6 g£Þøm æ¼ÓÝš[þ·Û}¹ µ9Q?|Xš&Ö„[ Î+¸ê*çôʪl ˆ©QI}'žmþZåídGK.3 Ík¥ê¹i!c¦|¹¡æ4Ãf)–0’`QTöÍð»Ý!Ü¿ÌÅmH°«¦cÂΫ %ø^D>×6‡AYGFÓú?ø@°"î}z!cvÛÔ‰©gºw-Ž ×§¢â<©dX¦gýÁÇn d¨ 8Š"jp¶¼pD‹°}ÿÉ£maøÆÚcÎ:P”y]ôî6Ú4 /MC×|–u'¥M¦®ÈË%zÙ»(•¶ëãZÚ´:Fï^‡y 䘺Ç÷úVENs`A# ²4ÚqÙ6W¹:TUJ^|n ãYí¢Ï(DâSô)…]àƒÛy(•ãw¨Gä/ÅmàdùùVAû´…PA~Úõºdx•¾3¢>Æè9¹ól @ŒÿkŒ˜Æù!UèJ¥Ò#­07ÆWOu|±æžÅðF@üRï™`ù2ˈ«Séj º¬G6ä áQ/k»Ýõ0i<©ト…2‘Ōܸ•ŸÓ“6'üÍÄÙõ‘½šÇ ÂôŸèÍ¢Bö­)§¼¯°µhJ´z•èy.6¿Ç'õˆ÷צ /ëËÒ´±fÍ_ÔT²š”Ù~|ñÇ‚ 0ZÂý¼¥"¹„v•sk-Aávþ|«.™¤yˆ1¿ž~9é†Wx ÚSŒ¦eâN_Hþ‰86+A/#„F<ÇÍü/{n¹ÈQÖoéûγÔꌠ<8Ý ”¸^‘:Æ:è8É.R@`²9F™Ò”:jXkf ˜ãBµ¼t ö—úîàtÐP°ôg¢ŠÑo»·ÂÐý_Dº¸M„™Y¸Çädš£kZ¡5àƒ Â°¢’"s+‚âáÕï y ©…6ò0›„Ó!êËH·òq9 ÐÛ Q{*¶®/ 0Qô£rn´—Çï!®©m€hë,°íÒ]«/‚çýä6ñIIyjwo^T5(½¹Zåh£®BYö_hÆj¼èºÛÝå/?©½£Ú}³”Y UgÌ?4ø}¦gÑp9!u»õœ^Ž_hËÊ´+¡ë;veSoêsÇjJîRÃ"ahÏ»/!èA²‹%=jÐ,mçÜ'ü©ƒd¿Cúkî6¢-hÂΦ3 •-<ÜæwÈä:û• ­1¢ø›þ%ªÂýœ ˜Æ/L_O.ÙÑÝÿ}õ¡þ–pý«€{ÖW2ÅsˆB-°Ö“Ô|&t‘?–uF¹ý¡¶¡v¯çË%̱c|‰6ÔÈÝ:@©ÃsΘ-ÝÊ`œúØ–ÝxNƒøaÙøuË×c0¡üÛ8“˜u^µÎeÞX ™ž&ˆr³±„»·™qQü‚O]ºËýŸuÂõi84_¾# VOƒ…ô˜hc4.«Ü³Å;n^£PíwžÖ&CÉ0Œ/k9>|{‡NÕjoB²ÕºÓó·~èúScÙà¯úÚ¸QÙ·ó´ÆîJniüÂ¥÷AŒ*Ú–ÿ8iM^'8õÚÎÝX¹–×tTxÏN„†d®5ö¯‚¶,Íd®ÓdYøpèö N(ê]ÔMÂu>€udÛŽ©µ§Hq‘ÒÊx!L–ž³¬£qñG.Îf‡­/¿ýs(ÿW«À)ÿiodúºÓãêÆ —óïZÚ¥ç;°´*Ÿ×à:ôÖ#˜„™ýZt×Å·ÐdBÇD l|FËi#õ]HbfËÕºé j*Ø¡[ŽíL,²1—õ=Ikk¸]WŽ=ß&ûG4J¡½oŸÌR@M;À©Ô–eâÊüaoNÞkí^c•å“•0Ì–¢¶Ia¢FicÇu>0iûT…§ç:t%‰°M {~õCÌÁucÖ†Zä)â‚Ï2•˜G4€éøÚRÝQ˜û‰>dŒTrÖǽ¶áA¦°)ˆŸ½äÃ`ý¿§hÌ3¡¸®3&‡h×d¼ehóËò°Š6ëy/ Â?ç× dL \éîð|m®êÌ9¯UËò2ÍËÿ|íñ–£”¸YíàA‘”w¾áÓN–Zc”Ã’YæŸØy@7`¢b§-Íg/l@Î Ñ,Ø\ò ·±HÉ“°ê1(}£ûü þÊ–IA0;MŸŸ7€Kð¿§÷Qö⯻9â¾\O* b9o?a30*adQ¿_Ô)G•r[Ðr[:æÍÂÚsæ+©Í]@Hå…¬:¼ø¤áš6’v<ȸ0ÇÖÇÔ ,y³]ÆÛÒGÜdYT7.Ì—TÂ4w#¶õ$ÔŽ*ºÍ}1”hö˜Nˆ&3øò+êWͦP¾\ñ°.TÒâa”5Eà£!!yèæà^«aEh `{Œý%¡O?vFç™î7©|0ѹ7#{ɘN/TG¢ É´b^²ïÛ0*ø C„-½ï~&8ª®‰S ÎŽªõÎc&úV*¼¯ºd×EÛó¿á"Áhëiwîíßç.ˆBg|þ»WIHL¼SL‹íÌJøŠ¦+Y—ÇžÁ"E­—O캅Èm´ À~¿:'pP-C5“§!Ç¿c+“nÉ„K,N<‚yÖ#ÔpÂBY„",.8.^æ™ýˆçmxÿa„rgN%B°Çã s'êiÌ4Œ%°Çß|ñÊ܈Ò+ÃØ¤ƒ öRãÒÇ÷ ›#Š’³3üÌѹ6j§=Ë\¹ÿS'ÓfHNvp.b­·ã­'E ÝüŽójf…ðõô4ÊÏg?3xŒ; "Ѷ ˜RlÐÅB‚$“N¼ati½n9÷oþëÕ~xìPœHt°ãN…ÚEH±€óîl þõJîÞbK=äCëåšöùO"MFô±qÕ}ÿísùj^,U àTj¯ráɫڙX”=Ä‘“y+X¾’ëüóÖù,F 2§»ξœˆ·Ä CuhADÔ@°xŽßp2êØtB8ÇŠ m¥}÷9V¦¤…»ºs ¦šæcœºøœ'sv¨f¦‚8wqø©|íBRqŠÑôWþ”ƒ¾ê³‹lø>£ÄÍ·…› mö].ŽC= Æ_ð^ wТH·À=Åѯ̰I ~ê›JGù½YêuÛ7ef“‰·¥Œ˜âWñ—ó€OÞ°‰¨¹/~öç¼.~7÷Wpà×F¶¹6+„Û\j”_øˆnû‹N¦PŸŠÆ@>®>Ë',\¥¬k±ôÞ¥qºéPêÛÉ¢‡0º+™±/‚W•á`ŒþÀVÙôÃÜlÖ&-oEé¤ë¼ÄìJËêÛYSþßúÈ´6²©)ÖíË¿$Aøx†nzÄX÷:Ô›{âIÌÌU8ãðÔð{³æ–½›r¢9õ›"{¶(˜ÜºJp>wœï{ÃqÈXW]¡ôÔáj±›i™µF ºÅˆÙÝdðÖ#8رpÐŽ[þ»]vò’-zªY¥_^’ÕÍm¹JÙ8À<“BŸT»™·üã>z1 ºÇè•6+:”¡#ä6³túìf¡¡Î‰ë[`bïm:‚ŸÎCS0u¬Ó9^쭖ĈÙn+–¨Öù½Â¶%v>ŠiP#zD‰jˆÁÐÏvÃFj{Lö¨H”¡h&pR7dd݉j­"5ÕÿŒ_â½û^M‰=‚F>e©qAº^éL4¯Áxùªy‘Ï÷”?'5…IÓÿì #R³W5;MÐÃ~v„«oýéÄß8o.ú:ê"×TyŽq?P§OÁ6Ÿ; ‘!¢xgõ~ÛåôvRÍ´®Œô3/fWÞMߟ“gGáw:¾TÎÍ&(–Äi€$¤Á’¹*€àܪ„ç·ÁÈ¢ÁŸ¯móÑw ÒÅÆùg¹Hs*ŸT$ÿù|N: ÙRE9LÎDÕFjýTÖtÔÕÎó¤6ÁäTÿYúëÚŸ$Á댖c1X|ÑŒ1,< â<=âÚ#%Ã` ÂZ¶²DÔ+÷jòÌ27Öµ±–æ_5ù&±>æ®áÈÌå† ûrùX/èÜ8"tÕ}2»9¤w )·$ÈýÉ9ÊE`?K.¨JmöyÁ©jdî!±nĸbr ^Û5ï^n·m­`<¿{ä)ƨ£k.ƒ `M3ZCèÊl†$.Å® S¡gyЗ²;NÉ{ü—o—ãƒì¸ƒ|›EdÒAœYî¨Ú-¨±<n´ŸuH Pý!Î–Ž‚›àÏÕYH‘Æ—RÉó+ðèˆ~F›Ñ;…Û$F8¸·çJ{!¶ÙÃê—` lدþŠÑÛ3Èçúè°òY0¡·3v>E5ÝÄ8´Aô\/ÿ=¸c-²êI™ EÌû­‡š^°ãÍßåV¹&Œ×ŠÊˆ‚¨¶3>uYlçí|@­--ÍB9°ó0ÈúŠâqÀ,© ÆÿaÖc³dß &ó¨ÆDBOÎðœåás€ ‚t,ňª0mÛç< PÉl®k æØÀÙ÷ªà €½yèWLí]¦ôi¡¬½ÑB|žÜ5¾£³vÖ(VQq0´YæöHÚ"óC^ Á²™,ìýøÜ<|t’Ïnݰ¢jÐ’_îÞ­º¦Cf¦Y÷tᆀ*íëhÏ6¸?K¤1;Uöa8¡œ6þ®ï,ÝE YñêE>-ø-{5ÿ4MÐаGŸÍÁþ6:6¥x9ʪ5¿ëô³"ÍD,~ªª¼…{Ü;‘+T”4-óÛ­ûüIòý  »Œ’¬ÖZrÿ >H¬Ë:>|¹(ŒQdMP]Ía=7¦¨7»:^¤×‹S»ûÄ÷¿« i”ž¬ÎS«»Ò?êzÕ¹pO ¬‹ü³7ê]—¿µé˜ ²cEdsm`"W$ŒàÙܤ†ù1b# dx¥DÌ-ÎëöŽRË óMÂÒ!¥9ë[„5ª•…6ØWP:ž0v°½“®á”’?#¡ÈÈÙC––SàNcfܶ¢™…FšChøiðÜQsú&%‘šjÊwþ.VGXéÝ8{Ó^ÿÂ%e”§z$šóR7Ö ƒ4wû~6‰8—ŽÌ;°De…°ðd)NúÇ‹*–>tÒÝSº=X¦ªx&+ôÙÏTã/€Rhu$>"Í@ö‡·k¯„9¼z)a¦~˜C.£ù½Ž:Ü2éLBLë‰Ã&¶fìQ] .¹c„Àz’ik–2hqÓÙIš`JCþ•”ÊŠeîBÊ@_ž™ÔÙÄã嫎6|6ñ¸Ó\ÿÂÄ ûFj+h8•:ƒn00‹C¸úŠ#3Û#ÃÚ|$Ô«]ºOŸã˜ÿ/7t9b-Ìî=O›îŒÆ_;J×—¤•P+/ô“ÖJ÷/>buº…ã='e·ÒÉzÿÔGHìi'õ¾AĹàñU´¥‡eµ¨)H™8²¹dk|Ú{V›U]‡6µ‰ Àp$¨ØK÷F:‹d½Vôz"’¥¿UTKì)×_œ x8GSÇÙÎÔÞml¥vö°LÏ\7fgû@J‘ýnû–{ü9¡MJ½¯ÂÐýÖì#YÖñY®»9‹¼‡[(þ,afÐÈŸ;Ag÷“PƒÓÙƒƒEã|oåcîà¶”Â;}•mÙlZŒ]‰F=ßãx\zümº èUÇ´åðѬ¾]™ÙÖFìPQñ&,Ä:#ÈÆ½¶¿ ºƒúžýàÏ 0í5 U6z_ þ3d©@úSØÞˆˆ˜qãÝãøóÇ•äHjú¥‡¬uV7Ïõ¼¤¦ª| ƒÑùÏÖ`¾YÒÞâp]8Ž—:Æöwß‚cóud±ž¦Ö»F»£dù`­í$AKÉë[œ˜YKsü¾P!éáUi| «ÛÇ-8±Æ+ @¥Q@9mæo#toE`U®¥XJ“Ahé&óèÛÀÈ îõ'׈2€çÁmª IàýÁL¼· 1œ‘U;'Øý$Gi>L÷1·QËÿ~¡S‡¡>Cò;æá!ø+¡Åеu¬Êv€ ¶&1øé¢YË,©½ß¾šÉÊ",´á´†9¾ò(ØY«;ÑÆdµYGÜÓE÷ ¸MFY”akÃÞê[„›î…¾íå²N è™8Ú g_5A1²E:³wýxå¾Ñ©­½Î šÌÄV Mšb*É›f,øD Ъð’íÍòmˆübEgˆ ÜË©²pjœ)µMO\„¸$§%“ŽÊ9AÎ$²ÛHKòG·¸Ðÿn·úA/ „'¶ ]r* ¿Sªeð ˆ#~ËýÿÑÆ¡ÚáJó–àÂ0‘üÚ€-¦-F¾Ùï\=vx»€Š3mÞ>;|ÖHM!.ÉCmTÚbáí)$ae(´D>ù½ mè ñ 1Îÿê»d)r¥š»¨‡õQ» ´j‰JU+9+ÚÃ¥…w ùðÑÚ‹RÒ…Åm?–3è“…Ë„ó¿&UBv6Ë ͇x;y;^ª¥ãè1h¤HtÐ'5ýZÏe{rW/ úÁ $ÍaéÉTNY c ˜Eð©^càêÇÍhúwD¯é¡LHìšÁÂ^69·7bbRn˜:.icøó³å¨Ðùèb ‹L©˜?ÆÚ‰Å>?±R°˜ù—]K„6è1¨ ß ¸'¥Ë.§BmZ]9Rù,þ‰´R­ "}' €òºÏúσ5ÅÍ)›3Œ(êw†¾Ó<ís>#^ êžêÒ©rD–S=;€G¦Ç‹³­çvðq=þ\éBfM•8Æ ùOœ*ã7gfhQÅSÇÂÞ* ˆpB$Ž¢ÅB Xð7Œiž…öøÌ™Ù™ Åûýn˜®õÝŠdª"dtúùl]±%Ï5[4„8-¸ŒäpµˆêÅ)T5wŸÊÛUrh—×6=× ®ÇGàNN·;zƒPY¿d½?û¾¡rûŽWƒ8rœ›}g¹)y–¿CŽü/FõóÍâ6¿•År/ÕÞø:º©»¬5>«{ƒ¶Ý†¾*寤Aœ//’h9ãïT_æô—rm0cÖ4’‹ß w(£Ý ÐKDŽ?LÎ[ÊÀ Èü$W#OM%®¾³Â$\ZR‘ÌÀÖ§sÚ|#—Ó;´3„·wh^åhw²ò*Ð ¦Ñ¸h4vÏN¡7îãTÙî¡JnŽÉ‚ZUvJGDònîU·§ì5­ßåmwòdƒx쉪¾IÕª/ñÜÄ!£µ ]3Øm¶jR›Í‹J¨<ÿŸ†Ð¼ì‘_©ˆp„‹ÒáC?ƽ?îŒ$72—ö±ëSäÂp¯ÂŽ•Ú4:Ο¡¾³ÍT”X—£Pï³—D6í!Š’v®óÔzgĹœÆYZÅt5åVä H”‰|¨)€*[˜OÛ Ð"R¿Ê–{/4~‹@¢þ<ê°ßÛ.xûàˆÊBÁÂ#`œ;×ç'CaûÖ““ù$†öÔ 'i'ÈÍ.pÛÜ0áäåÞUú¸-D¨]VN)w,4y~RVï¿ÞËÊþÃãdfçíÁMÆhP'/›Ì×ÍdXM‡‹ã#õg³Õ›=ä½[* fÀ›HEÊϵ+§÷ØŸ C #ÈÇÉ'JtÏ¥¸­]MH‰©Ì3Ï¥ûâ«—ê;$(FlÛ£mÇÁ\ùî—§äq®q%+Y'©Ð¥!MY¬T›/ .šEÞ\ùîLqÝW‚º¶§]LWzÁowð’ãÖôN¨+r9ßÞD¿é•ä­†å޹ÕÎÝÕ$ f·éCT½¨=èŠQ%ªÐ[¤å6ô.Zî¶Ÿ ®”ct!¤-äçBßh_pUf-Ò¬g ²/Æa ó÷vY¶’ÿªÛ¬ºàK@í[¦Þ-í–D™ÄRB›ZqJÂa•ä?¤ØñlEäèêd3S2¯^C ÈÁ–{%…"Ð ÷ËpA,6³\ m׸ñÛ.QŒïD7zO`•+½ø¹+FJ ER|+8"Š-» v>µew¥ø†ÊÖ†+?ŽQZeeìYõ¿cVöß'¥ñ³8Ùèú¼ÛÇm ZŽæÇ¥a(z÷ŒDŸFîÖ›r÷£¯‰Bûm˜2D/3jÞ‹Ðf@ÕÅuœ)°åùÅ"S׌¿§wªZVÈûTí±zEç¢^RFÐk÷'†¸>'°ª5Kõ×͉¬Ž—‡k¾$ô^ ŠÝ˜ÅÞäÛfÒån²¥}”GS3úté)7³Ó)ÇMa~«¯Áø%MçõRH˜)Ïj¬ — ëÛ1Á¢‘ÆuËêdÙ Z'¯U2ìùÈ{E=öâ²u„P*ïN^´äh¥5‚º‰âÎ{ij¸ )‚-Í—× ¸½"e…Ö˜krb«%ÞjZÉâX8ÐMÙbýzlCFö€–ºéø¢Ø 0ÆÅ WwfhlkYÜ£^ͽ™n”úœÆ7\Š!Ïâ÷tÏuà¤ïX¶Þ1wšo~—¬,àÒ’”HН»¨ðE‚ÅS7Ô×@¦É}z:¤©|˜óÃÜ_›M~XYBÀ&Ð9B/Ѱ)(ìÄB¯›û7Åúó͵Ê&ãäI5|i×£q[e)i7kp¬y“㧨èoäŽÌ(í¿ü“3‘å®ë5PŽãôµ]p£zÝdÐ:s5˜7ûrUKy ê¨P¹ù G¦ÕþWû ðÕV’c8Â`»±9Û²Ø\â–Séæ¥Â ¹4誗`…+\ï ÐN×:¬) BÆÔKÒ›ôWJD©*q÷ðo_s4×W?E§óa\7ƒÇzƒÈÒÅ ûǘÝᔼíKéZuõù!Ð5øz)´3K~³N•õ²@ʆ ºDô,`ƒ¹Ñ­w¶#[ÄZ¤Ê[dEøµ—3×àe5±ÇÍJÛËtÊ|g™a`óãU³óãräé×r%²%'Ý¢/I:Un sf ;^õRE?wIu–ê')جÂ7·mIZµêg/ÚþZª´¹b–Ï›RÈ€q^ }¼I½ø%²)؆+Ænÿó!,é·2-~Ú3H|iOaB(Ëre!»T,oÀ¡ånw [ãî-eRøÖ ¼ˆ $B[ÿÉ]ùÅ¡×cÿœ>0 ‹YZclubSandwich/data/AchievementAwardsRCT.RData0000644000176200001440000031252014630154051020453 0ustar liggesusersý7zXZi"Þ6!ÏXÌñ>_ïþ])TW"änRÊŸ’Øá푼’ÝJ ˜ šzE‹#wEæXã‰ÈŸt3I½y©Íø½YCá/cfvesÐÒÛ‚K¥ÌþÀø$‡O߯øáØä pRÁ©ÂѯÉRt®¾aü~;S¼#Ÿö! 4[ç(ÅèÁdŒÓû§âXXCM™œ.I†i| =/|BÑ"Ûʈ]jèËèš"Ü;Á¯^SçŒ;O6ÕåxÆŽ+vÙÈôÚ ÑÿW-®§yåmÙrl«Â˜a—ú™X~¥šõ‰TJÏ/ÂÄSHya·tÞD‰Ê‘À÷Åsý¥<è Ú)-¥[pW6éÂg^þñ K4XïFqîçDV»?-„gÓÇ£ ò ÏâÄ#j6‘ˆCx"Þ½ªûÀw7Ó!°L&™Ðý>ÐÌF¯¶ØŸ¿.Öë#;dÿsÒá=ù.žÌ­G‘?1¨¥•7«};êÏ#~MøÌFÖ=MwL 4ãìJÓ&+åzàÈÕ@-‡ªð0”¶Ö#èMšKOš}KG­ êû0`m’Þ LüîŒw(SRêùP{+.¨ÓË6™r Åiùþå4ÀÚ8Õöù•î Í0YPáÚÇ“nçæÊñë%´QÐ^eR&x¯f HÀ÷¸}~@UDêøòxª§¬[§ =¸Â`q{- «4„Ñ´¦¯%ÈtîDî0j£ä”·®hõ˜`â¦í¼ì`„~,Ú=…‡kšGšÌ¶Ow;nÞ»Þ$Ru@YN×d¹ãFu;\»’ÊѺ§¶oRý…lßÄ„˜ è0k±¸3i¹šW©¶/)p@% ‹=© w%äy­OºË„Рí(˜‡Àsâ„8ÂpsBù ¿"°|TM ä.ÅþkÙÉÅ «„†½É”ŽéEö)¹ïøÀ¨"ú:Í!@¹ÒÆv到üKÔTqÄ9Ð'Ö·±. Eñ˜’l!|‰Fcù±Ë¼çFþ (P£TŸ0%Ý€6(ÃvŽ…è>Ç8 ºî8ÍwÝ¢ˆÍ¹ƒ‡k%j›‘^ÑO}å줼´O x=V‹åLÛ‡¯R‰Au\y›Ò‰AoTrû¶;×(ÛÊ«nE\?KÚ“C˜­%`u–?‚æÁ!±Áíÿ¿NlÝHýÈ/ª¿¨P.ÇjTX'ÓÙäzÒ‘>1F,®ñýR}×ðÌ’·1 î(>C>$m q ¸„øf.zŽ.q¾t……ŒôëâK²˜c?ÇŽ¥fHÈ —b^_}³UîÎ÷<£MÆ\ò»á?ŠäÓE+Ø÷MiÑýãrlIâG¸ŠòynèÇOÈLÛ+¹‘Baäëû¾tª¹I(ðð< ÷ô6ü00¿ÿ0#šWVùRN6¦ìGFÖ×ã)îŠà<èönÿkBðîe"LÕÔ¦•û7ÛÁDŶ҃Mé‰B-ÉÍ‚—cÝ G´Á²1æ÷xcÿ- žÜÎ>÷Y3Î.çÛæÚJ†Œ‰Ùj8%¹!…=ÛÿyPÝ}•¡] ° å! ËåÐ9!¨ì¦ù!NךR* Þ#Ç—å_µd`/YÐnpµÈÓ_',ÿ]0…»&LU‰Têª ‰ûlÔº3X€18Æ`ÜaÕ WÿÚÂB78ÅŽ ñÐ2Œ8ÙÀ– ÒLÐ5|*(\§.ò¡ì;/¶ŒC¤ÁnVïBOL8˜kËkÖÜi•žRD«ñûòWC¢d¿WæõHu#«|€¾q€ëâM¸žWef´&aŽx«QËE059*ë9ð×ÊÍU•þÈh@¼<Ûêè„9Ó½&£p‹éëåu×ßY`C(‡n/òæ^'DŠ\HK{âÍqenpíìËb÷ \óüÑE%ç•&¥ZHʵœa½A‡ÝÚ?×Lç•ÿ[ šå>ÏD=eùh‘œ‹ƒÄùßÜâ@†kQcS+|zoxpqÐÖ[`Nbœ,“Þ¹ ±=sƤCÚçK¹70+_&N̘+\gÄÖp‹9H.$Û;‚À9m¼²¤ZF{É)©<:%U3I{àÔrÒ7_VAÐ+F{øö ªü ·ð*¼€9:¯±‹®7™Ç¡ »ÂäŸÆŒ“·Z¾µj>€º.D«Íî“Ó¡…8q¿ò´©‚;n­dDYˆŽ›Ä~4´#\Œ#ˆ “)D(àùêÆy%“-áÚÙĉ"“ɆO ÏÁæÑô?6c|€©,«Az³&HP}®qrR4ÙšvHL–Šz¾¸À¦ÇpÏYöIõô"†”‡Ý yã·´^}òG-WFœ¿òwõ?~ ‰DÖ©Jÿι_›ìH¨­k Ì//@>KhK‚³¾‚uÈ’.»{Ç|yÜÑK)—ÒPj©áŽZÀY¯Ï•ê†Î»Æ4ý”½ÍÊúˆár‚ÉI ‚²U™†z™5jŒÐíÅ\yÊÁ^ûÙÌ”L/ ¨,F¥-¡sÿ—]µ7\mö>F_q`¨Á8òY©‰󳊽ðå;›¦öÙ8µQ×|OúºÊ•®ü€yµè ,‘W“ãW4ÑQ28’s €2=@㉽ñ_ÇäƒÝuõ…lêR§¿‹°,ðä—hЪXýã9Ïè%joÖÊ?5¬‚Ÿ–lŒæÛ˜Xµ!¾¥¾pè`)¬e«’eß0"ò,«˜t•¨ô½måA~YCF‹›Ù~XtëxÑ5òp;‡…äþŒ)׀ߴÂ"Æf2Ó‹Ìv†¥ÝÀ ÿæýÚk‹ ûJ»µ¨zš˜éü‹ôÚ4&ÖáëߌðFú?¬(W£° ¢¤Œ0äwºõ?H-Õ8{dÊU[ÕCFDqísÌòG^ž¬b¸†´RÙº”3Ð9õ-0š‹t©ŒÞ s€ðëÊü`½R‘ê?—Eÿ”á·¤ ühiîwÿÆóp53-ü˜/œedåfLáåËkZ(Ù ¤ úå Ðéº:…cÇzã`ËQ Ü(ÓõáK(Œ£»=šC‘É£•öØ«cÃj»ËèŒ{mõï 'Ǿô·€m 6h«rܤ¶žå²ýkñ#§‘r¬¨Äù®àýˆkáH¡ªŠ=c¬RS×§lÄæÔ=•ÿüÌ`û@{`ÅQù£I›Fd<8U.éÓ³o©c˜Ž®yÎðÏØåÔ ]d?ÓX¤ŒPSpyÀí3Lš£]ç,£=„Ïör¦›äÓû“\àÖëùå“OóÑÉØ‘ƒPLƽÍü—”?`s?z×T œ`ŸÎµM¿¯ý¶)0€‚þ9쟌÷:¶Åµ£’²çäÝðÄv—§=í¬vü–òŽn¥Œ»Zú `dceåtö÷Fõð’Õà@)a»OêÓÃ-[&pQó^¹y¹‹²Zc[2ýê¤U ˯ ÖÂÂdÑOßN*C¹zIlæøT¿·}–=ìÒvlPDWµ®–à?#À‰T¼|@C"¬”Å"ua Á‹ò˜*VtX¿™™Ñ?¤lϳé¨à—)!NÆ}êFÄY‡ëWÞv$ƒi@×þÔb?]Z [Áü«—´!0•«Î=¬Úˆ¸ðšÃ! Aj?í·<ŠS†3Øì[(}žÅT*¢¿êFQ£­çèo³š)‡ç"Ûš,Ù » ‚ÁA–Hð’87ÈéÏÙ3‡Ô’!#ÞýYŸh¬ÛòZœÖ…ñ¸=oQIœÙ) ®ââe:f@òÙ}ê r‡—;ÝÇp…‘ %[¿CIÕa{áØ’OÇVÍ4‰¤l\¢9÷ñµ¥°b˜'¡¦"bÎVGÿ¯tò,‚ÜÃö‡ºˆ&ãP§ZÎM[ÉÛmÚ– Öó–›\÷UScg@é u[—¯ ÁàjÔª¸ýÊè(°-h¾ìßfH*º¦•BáHÉ»ˆ?¹ ºeËS•®×ÊÛ]š§õ©#éú”~%ðÈA+:° âò#Üâñ\?Í€"U¢¯^?În´˜—<,4¯òÝÇ-/ ?ÍÇb¨/”œZlßD$É™¿½"do[’´sKy<ü—‚]ÿ¸âÔ®Â%­OCocfJªC DW‹,¦~|]#Œ§K­U‹è`aÆ/"0,Šü»MÐS&¯-³dL9(Á7J?ªˆ ÈÆ×¨Ð5EUU‹Z¯§D _BßaÂI¢IÓ°{fh¦àvªS!ߨpâí LH~ý²‡hE©|Ó”¨ómýûBÏ“s[ýiæø±ö½&£¡å1ëÔÖO¹]LRØW‚J­Ö‚5À˜LáÉ ¤×Šà@d¬®…¶+—<³Ó²ÇÕ%VPC-µ¢ÉUÆ?uèdivQ^ÒÀ°x£UEB ¹J”qO/Œ„·|PþÝŸ,ÃoÄר.eJûÒ±M”îë5|ÌðG¡É—¸²è&S¹­|B9°ÞP0ͰßO»¬¹Yj½7æv=Žt¾Sn¿/Î4ýº,ö£ â ¶>GFåŸ'] ›=•'j´£þp˜£Á8€¨8š}êJIÏ£êûʃ3_"ÿTOR¼CÇ7­Fõ¶'„ŸU€º!ðnÐ'~ú ‘(¥R4nä•ôÉ‚ª½oà7 1e vË£ÎåÓàNÜOø¸åé$`ÃËÜvPÀäpÇN×Aa§ ™/&}¿í~нK%!õÁò %:½"ó§]BŒ¦·t3ÙZ8‡Ôȃƒé2»ˆû×#ó¥u¸°~1ûOðæ.^•wêã¨ÂÆÞ1ŽÎRl¾.[tóؘCñ>²3pýP°Ô–Ÿj 2Ì “ŽêÞ™ú?pêµµðºåœ«5½e?4Çøý«ÒÁârN§såà1z´Kãé`Ùe8ñn­üþÖjkoøa%ò2Gú6ï¤Z¢’Õhò -ByµOyžÛšÆŠ›sÃ])Göraÿb¼c˜oëõ:Q<—"W^‚€¼Çtç [ò-]ÿ ‚ÆÙè§&5ݯÎWÙ%Ç“'¡ÏÂ!¬`r×Ò?—KñðyðÄHS_¿åT eG}:4ÆLYo)·,äúáÚ ›€Ù˜=8Ô¦”üáâ«~)<«¿ýg×4 ïÚEQô”‡.ÞoÙ\ÉËÁ» ºî:´¤°·ê#6:]ž¾oÃ>V>PþLÐé|”·xÐ<ÂéÎÂ-Âd¤OÄœñ, îçñ?”¦Uô}ÚôXÉ„¨ôä V®Së1êmÈœgŸKùÍ¿BÉlZ/ÃÅFýog»lTŸÜüx»6ñC%d9 àF®Å‰%ru—¹öýŸSÈDäNf–tC#õX³ÞÅLß;/’µJ×s`41…aþ÷ê±°à#´DZ¥·=.^zÞ <ŸLm_CbLû¦ `ÀÃÍ®aïAYz´ˆeWjÏVaî–žÜ 4ße¢ VjEènŽ„%kÈ&ÙïT¢ŠÁ|`T1zx‚hôûs¿ÄHûb9óÆ2g‰JÌà›ý¼oø‹øvò×Kጪ8OuÊ[}„.7öÇ¥ÏOJ -jyG™vš0ipÓì©an^å T÷¥Ÿ!è|„h»ˆbæ÷âÿ°¸ÿòÒ¶ÏÌ?çQЀ¡Lôþ ðÿw [n3u9ŽßÆc òlÚµOåkðšÚ¡äã’û‹žÇX¡²ÕÂÓi…vÙeÃ3l¦ƒ¡hÇ òô0ÌÖ>Ã)cš$Õ”i‰×æpL³ó&¡™ÿ»PvªU˜- BµÿȸfxÕdÄ­Ë[%¶µê•œ$¯¡I­lˆðò9•ªyIؤZ5†½üš cŸ~}O~¸.¬Ãw¥ˆ‚6Ƶ¦=bÏe¬zÓV檥}0Å-ŸSö»\0ŠÕ¹P¼ºy{踆[oZÕ—kàO¢<ÀZõûAÑ®|®”æÆÛ‚­­æ¨ Q÷]Í'àðâ7(‚~jm+zŠw)6iÇ`jØJ±v!=ÍèRu1t– ~öe¦ðE®,J|ÜCpõmEÆêzë¦ÞòOñ½paÊü=;Ö‹­·'¡5}!­1 xá&¼Fg¯l¡µÿ*Ïïs»r6ã % LlPœ™ÖPÖ=É]{›ßhP>‘%Îç™ûð¼K^Uü©óH,xk#¢¹|N–WcêÉfצ^÷Ùæ·–W\CTy@²N^ø§ÙUBx]›ã4J:½_l±*¾@&¹âÿ:‘æcô+ÂdŠóÀž#á68oþ˜VÌuþgàVFeù:玱ù¾×/ß1˜ªA¹8t3¿:Ÿâ¡\˜™I*šçÌÉsSt¢?/:A_r‡B!ö8d×E Òz•*’‰Ä>mÞl¾6 1’îì‹Á¬D}¿½†ædÔëÓ „ NÉÙ4{’rÚ²‡uᓎE». ÒL¯4)i9%†´jt:NgöY™1‡/Œfv±Ý“C",(kn›ê÷„½T9¡–Ö~PŒ¹–b'Ø ïœ ¡œD!K@/ͲqeÖ—‰’N<Õôôêû(”¤¸ùÙòÆuó±we[ÍÖ%š‹ÊCJÎÈ´ÒBIEk„eûl ôøF×!®™ïÜpù±íÈmÝäù‡Ü:™n"²Ý³ üwZ’Nkûí0ãa_Æ*9Õø1œ„Ä Ó”E€9ñŒ‡ñOú˜ B®Y—Ê ͆,C³÷R»ÁS§§¬¯æs 6^º—,E±¡™&7£J\»þÿ8|8B·ÈA†û96ZV”k~NÕ †È¥¢A±[,÷ÀBk޳þê"B䫿—™‹ðH°_4 åŒfs?5ïÕÖ¦´•;0´~XaÜ–M^Üœ?aâe"]j”÷íO.DÜüÜ^n«1/b7= ÈØeOU²ÕìJEKî ³¤i®EÂ"‹*n_iDÐΘœ‹Boê¹1Ö™ÕJ4…Ô+V $óëÒ&ãŸH3¤ÿ,µ’eb(ÙÞ¢÷Mù' ©ú¶«ÖspžðZ‘• ÝgÙ¿8ùX9æ‰%ï@Ñ0Z‘è–¼+ÈÔ«ß„×~ò7„•I9n|œê·ø(SkÈB («ÕëºÅfú«FŒ”\\U»ô±aM*8ѦŠtº&ee§(»Ú(âmqßVJ>)¿ª]ZìåâU¸Ûã[>_hä­/Ægš¢Ën‹¨º¡r¦‡H<­t „…{};+Qì ¬=ñǴ Jk"Än€tEÃ$(ùB*ˆ_ÿ–Ð>qv²ÇŒ€¤aÑò”,Ï{îQ=ï;zÅf›‡— Ã+6´ÕF4´OJa Ê*YøšøC‡”˜©ãïŸx˜ëXªÎ½€ ËÃÓ-IGmšß¡Ó%å}Xîx ÅD¹“irr\♕TYû—Á‚K€þ!MJ8]LÓlÏ6KP›?ç®ù´r—ÖÅ …×ø„ÃtþaísYGO‰Cýõgy(|ÙåPç`Í:l‰Ó Tóˆý‹œÜUˆ6û6¸£&.#lðy6Eypñ­ª°e;èë(Ü C©Ú÷hÐ7ˆ„\¡÷4Ãø[oNÎãe¸šY1«!Öß•Þ+')˜£hj¶œ.˜EPJdœ‰”ýeJÛ øõPäp«A·ì¶\ ©…X¯mØÓ@2»~á æåÒ‘4«´äpµuâñ[„D”4.:_šš˜Hæ’®¯õǺÁÀ5Ý =ýâÁ#·/Ѻc“û´Ø„ÛªÇzqgþ”ÐÕ³ŒP;©ãGÚŽ¾ÂßÔx¦ˆð«èÍ÷ òãOjËÔ $ñ1‚îGÛG :€ŸI|ƒHÿHc4$¦€¹Ô{,„{¸Ñ›’£%,t|ˆ:¯h£ÌÍ(g¥ñµ Ï^«¹xos| NSf̲š»ZÃÍÉÖ¼\•ç„¿u±VžÅ•Àp‹q¨¸ÌDD9f©÷ àˆFå69òÑ«gÌ€Üo;½ôò…`“Ó +’+¥PIeÈ7!:Ó‰Nn&™b ¼íNÖŒ$Ué’V<¬¶z‘¨’뤡)+†´eaçì…ø²"óYñ»= ýÈcN8ÝÞ !±ß„ôØ/H4&U¿ZèŠàªncú-MÇ‚Üë—‚îÄŽY5ÎñÌu¶Tž°äTlE­Ô'¼üº)Ûñµ’êMgG£ÄOל_Fˆ,y$^hBg«í>k°÷Š#gGÝù{‰ç ÒKóO(ƒS`´²Å%3Ì<õ%>>”°àaÈêØoþcÄÛpÙÛ;•ôtëÀtVÀJ£'€ÐÎÇÞÖlũų Š%gø—¸ÄדWÎÛIÜYæorVû'‚gú–¢Ù/\ð§ŠPÒ§i1¥YÛ‹â­–—˜ØXMŠõØ­€u|¬pÁš3‰p<ˆEpÿ­Ë oaf]@`Ÿ} 1Ǥq8Šô °Jï/üŽÁǽˆUÝÐÀfH3¯jsåì@<=*¬ŒÉ­¿2Fª³tÜI¹~p‚t—úD°z¬JàÚá0ìͽ3®Šÿ (&”º·+pÛkl¿®Êœfîêi`"ªê;úó=ưþuø®PSŠA^´¢j.ö›6aŒ÷-E¿½úËVÄ÷@ˆ~K])cG¾4ð!§|Anx·½Ð§ v•îwAÊtX\UJS&ól=7ˆÙS ª 01[ç?£Õ¯»*aßYR`Ö¯Sú•4X®× Èé1 ífa™¼†¢¦2·R(.øÏV™ ÆÝ!°4 (GJŸŠkyæÝ`†ÆwÞ–•í}ºá|{æ^!€E¼mŒ•Ѧu ~ j(UüX2­›ÌJ®Å0'hÇ9a `KÆg®—‡#E¶ºoT+‹p_¸Ö½%rMé þ÷<¤Rb¢¯äÂúcþsßIJŸ#¤YÂ(²pŽ7`×¼Cõ&¡.AQY’ÕÝ>mzÕDGë M:a€”ÿ¥8׫ìGºÝK zу™¶.aÄn/ÞÑê«•¶ö} ÈIÏH(_Ž£×h8Ë –.ÇVÖÇñínõálšJå §± l›'«¡éÑ6]vHõÛgÞÕu©»ú¯ËÀ°8EÄçnÔgŸ°´.»qPz†ù¹°@‡Þn@ÂmHá5õàßöNÑiª›ï¬û"xKpCÆðâÔ jÿ“ì"cDLÊCÏÚ;Á_Ž£áÛ ÃÆ«Ê`’ “²Û^rˆ<×_|ºÝ‹o„r³<¿×´ z"µfN€¤G9N·kFö²*ˆÿ;À¢RòÄ×µéðv1)Eƒ¸Ôý\®Ãh0®êÇfSgrAZ+.1ƬU³† >ráù', ¨zÎc}Ú±“â·Ð óЧ¤ß !²sRè&ô_çé–j ÜMV¼J’©|n07iZx£ížÉÞ}§Á¹ADƒÂ¹|È×ÆÄštƒÌ0Óõ©•&ÍêÓêâÙ°e¿ÄŒاkÌV,ŠOçKô^F‰ávêWú´ÅE Jk_ŪvBkaÉ<:þç7/!PšÓáqrÀW4zï~n×sì˽„¹©ŸSý²¬¥–ˆ­—\9gÕ“â§g|¹B Cú!ö"dèË‚§:fo0z¢éb ìpÝ =wJÇMÿѽÜÒ’„qsx ¾z)ôlÈ<›;@úå=P€=¥ðxù5ÚÙ«xÀÄqfˆ%“KÇf =&e«‚P‚té ×ꋳ´³bÜàž•Íø¸ù[G”,=ø‡…éF³™¿AŸ~,4Z@Oé–ÂB~1­`vêÌsmù‘õíA\Û™p~¹¾ˆkÝ.ã MõƒL¥/…MëÛ¡W¹Siņq]”äzA·zÿ¹¬ÃywãÏîhú0ƒ+É¡[Þ3èAaÓ6?¬QPM»„üÓõýK¥i×±ƒ"¦pÓ/§8Ö Ï5t$³HOSa´Úô»Ÿ!\ç*é²"d{‚øHíd+þÍWÕp 2n&]6eY 9*ÅïßX#VÓ¯.Æï¦Q.%°Ó•¦Àb®POy6¢ÙCŠ6ƒfÆtuáð¹úi¬tï‹ÇµP7ÂÚô‚vunID¬ã^ÈGjÌ®èsc9ÿ˜WsH9¬fÿD¼@òÖaÅ5“"ùœÊúÀ(ž¿H¬o[Ú‡­ìÇ5T_Z€p#>hKC'¼‡4OS‹ pÿŠqªBÓ†@¨ûQ`| }&0—esv¢ÛrìŸNtd‹BY±yò5 Ît ÿau[½È—ä4€±ÞüžiëóH²øf®ä…í ½nãsÙ†^Å‘þz¨ü½”îêÏr$ Ý—OÒP©=Ä$ÙKôÿ5a OAˆË0þ¶a“plƒØHnâq¤SûÛ6uÞÕ]°Uçðcn¾¥Òß°‡àß°V;GžðRü o…À»_X[w;›l Þ^7¸è:(ž?5|·YˆmÙ> , Âÿ÷ɧî¶!ÓZúã£#BvC«ÕŘmŸ п˜?$Ôd=sÇùJ ½gªÉbgSÁR àfYZÖœLSô‹ óƒW·[nl¹Û‘î½~{4”£…›Qq[ÝÍ÷EqåCY8€vô)¬Ôr¸°{ÀÛÛõ 颎v3Èå‘À’}]²eéFzv8`|Fò'oúK6ÞŒ½®… p«h€hšæ¤Èî“àkf Tà\^>È-B/Câ%Î!¢˜•A5ˆs¶,ý:Ùóå¯,ÂrËÚj®×nðª Àihã¿iÞc‚øw Jöùa¤Kg¥Ñ¨ãw,D+3ÏÖ½bçR°*…Ìüÿ‚(e,-¹ÆUf$¯lA¥w1ð¡[PI\X·™Õ çÀƒ|Æñœ*ƒ¨àŸfŒ‚ðÆ%7uÉz$§/Ó±AFi hè EÚ/KŠ›Kç:*J*‚:;$wÃäMwD:bGúä†:Ä÷JDFè‚dC*²MÕó>'x‚ÁdJJ\›˜Y‡_wH-zl3‡ðàŒ’ÍDÐNLªPÍ“ñòG=Ä^ÌàèiãòŠÄë`7½¨J½;%ÇÝmUù§C~šJI£KNÛI¶ætåINÓíW"Ü×Ë?¾p ~Z†œßQ´+‹{S¶8j+ZþË£âZæïõŽ2”59DþŠ/ùëfÒáê¢ÝlEYˆnü𠏩ô…!ºa–‰˜[Ù%"Vú(UPñའ…_bIª¤Ž½|ˆ¡ž Aí€sy+EõjóŠñRMwePGî›Jo¸uú2(|]'”þ+Tò„÷BB%)Þ?_ˆï·\ÓH˜± L~ÓO‡GSñ£É»û¬µB€'+4²øÎ"qÍ15µö³,¾z-³ÃZåË™Y6¿yŒtgÐ;ä0Ab&nÇ&±¼‰uÌŠ¡Q1Ò·¨(Í©*ŒÐ!Ât¤õXɽ´¯¥çIw´ù÷ba§þõ\`L’»Ì°“s=ŠáæËÒÉôu€DûoôF^ÁþçY²s'&>ÝJ`Z,ÄÒ±”‘õ"ÔÓ¶:H`O}qŠ_©^¹ í!â>>}…üü«óÉd u:VÓwÙä [ªm]Ã.ëð¶„Q6ESÁWŸ¢û1ÕâK¼½9]Ù¸‰jì†WÂë!ZyˆÖÒwkSÑ>SŒ…ïš«ž^¾ s¯"úžÜÊ>øªùñt˜Q[séVœú®t)·¤XÀ°~ØXÚ²j Ç@Sî¾ÿ·pMXp°Â€ƒÛëeoŒ <[¼Jù«Ì^£µã…@/wTÃìõ„Ö·@1¿‡` ðí>—©ºÞÑðg^Ö"HìÆfþ¼uÇ 3ÖÜed‚É7ó,ƈû¤‚‰¤(5V A”xÜzœ7±Ç$–ÎY’¥´È:;^c; ªlO‘žqZ 9 =ë³(bÉ[¾åm’ÞEf-H…ìÂ;ùü™²äõÏr/E?2Ö˜èƒÙr˜dÇ[—ïA@A‹è PìèØòJGd.Ú¬&"é/ïµ&#c…çcNwPÕ¡,¤OÙXpßz]ŠØJ7\À:kíÇÊþ‹s׋9sV/H³cƒ…b²`6«@rdŸ¯FʪàžÑ‚h"(@?èûF¨ÕñýÏ 5;Û¦\0u |˜8ü܆–?ï¨Ó†…Éè± €é<²±á,ì8ÙFNlíÿ™ã(VS WC„\Cò¯'#Ôíµ1vâ‘…×’ž¨£Õ%ŽUp«]I€ÎXx\κÙ@èSž5¹7zšµse2þ> BœmuSÚÕ»®e|ìTµc£²#\lÈ}Kј(­Q6%ãøY Ó–ïŸÆÍ€I{ú™r1Ç\cµ°N~­L7 ´¢³M ÛŸº‹nòߘ,µ°–¥VLÑüÃÓw¡Ï'8Õ=ÍÒxV¿$ÄøýAþ†âLðl„¿i£w€J•Ð=(ßxF¸aGZ;Xk:^f–ý;üdaj î ½ßý"J˜Âj†%Ç zc‚ý‰r—éа$À´ÀG½´œêLl¨×Äð__ØáÆî®6 ´)U¢ õIråBÆèXÌKvzÆÖ¯£çf$7’¬¾•°–úü-‡Ö uæ Fp™ňGÈ9 s{•kƒ‚\WW¹ú#òŸØ;¾³Úm™µ~{ ´û{àM½™Šs3ƒ+éÒþŽ¿>]FsçÕÕ݇Ûù|¼ã`{öxéiíÊBèÀI’Kúr*µÛ’ìS‡‡'àà§ýùPx»-‹¼Ú«ó¹ß;¸¹ä)ҩ݇z‹a4-½þø¢‚Ÿ€Î7æMwjÁÙžA·EfïãÏ7 ®».½M† -ƒj-“Ç×VL¤Ís}žr—©™Ç›z¾<Î#—á‰ÙE~28‹¬´át ë¶xôˆi†£WX…¥: :.¹Í|ŠEGl)ˆ"Æ~íx×¢ÃÒåáÒ°`],­ŠÕªê©á%B®ñ§;EaòÙu¸/Òkð$³°†D$ÒÄΖWª˜9Û¶Ã>NË 1ÿ»«ç\4¸Â ?7jû¡,¦°­„<Íèá2«°ÂòšŠ®UÃÖ³n¢£“¡µ8CÎÌ&L¼Z.æîÙKzg5Oî¡·ÄCâ‹“„±¸³ýÒ×Ì®h25*½„4VVÜ6ñµÍ–þ@.ª”+Ÿè‡Ë&ô«ao{–SJ¦!š…6ËK,¬¨ U‚ 1ohÆ¿œÛkMIå4»ò4Bˆ+´]»pDwÔÓÊV•@jL\^¯ÀS¤€E/ÈzeEWo‚9‡vãäT¯$ÔÏŒëXÞ=åRIx0*ñÍÛ™c픪^@2qö –ºVÏ"õÜqÐ\'ZE ëÁO连’Œ¬·#¢ÄLdà¾æbÔ:Mþ³l.#õAdež[ž •Ù„™ú•è„rM…GoTËEåWèDe3‹Ç~«UPÊIFdT£”T¼c›Ã3ªdº’“dÈ…Œ?>Ó8oÛÌ¢ù*Ѧ޷ÿ)&¥i>ïÑ0Ä»KÕÞö‰y)*tSqNfeÀšæœ ¹‚–£[÷Íä ¸›¾Sè¶”KºÓLñu¯±Ô,ëðÏÞÒ=„Gª¨µ'ÈV¤4½gVgÅoCú½k/ v2ôØÒêï…Ð&üعMÈl4‹Ò=‚·5Ïâ­±‹ËS2;LJŠÑÔ’ìÙ“œÿŸ2²Â§ã¦o°>OÙ÷ .qÎizŠö¬3HãŠèÍ8š%1vÕ£DòpJš@q”„'–ôU‡tÜØ×#d%Z¬0T ÅË‹T15Cµ†.ßÎAæÑ Ê4íÔÌ5ªš† ÓTÇ×M3ÙÁ¸oaÀ(§,Sdç™d¹äD¸#‰[§ƒ6Ÿ}s¤ „€1é×½\ïãúôGÅ'Ð#rùEÇ#u²“éÞ6a@‹¦3Âc6ÍîL0lšáœ×>°˜·É*ö£-M®ÿßv{s0¨å­‡Êb žG$Eïx©½÷Òa}3í;RÇ¢YHAòU÷^Â`¹µ$µ§Kù©Å8åÏMçl¿NËç¡çG¬vÓé–¸l‚ce@ î_M{ùZÞ`?)DöYi¶ÿk|úÃÐíŒ7ûm¸,OùaQ⇿Äë/{ÇGÈöË¡*ì¾^”'Ís§2û$N,4tL;IïÑ[Â9ŸšSÌ<6FõޱŽù«(p$r¤-éý×›*oyûûþQß}ÄÌJ²>`|•ýE2]A %(¹Ü<¹J-“åϯe‡Äá§!múËèfœT7ƽ¢ó»|‚öyaÏdY¢é°jzÞ‚FzŽ8@Kxt ·oGÞ9dJV!`ÿÅëàCmšgíΑ²g6ÿ+€Ñ¯±X2,[ÉEǃÑâ» ÓphyûÆ>ÔÒÁFçu‰CìK¾Ûî›@»AÑpú”¡v}ð ]úY”ì¥òí ¦!0¯Å4bèF¾œ“o¿Äßd±h)¢{&¢Åû€!žo_?WüLE‘ô>’²mWïIªýTwe ¯Âö´Ú¶„E¾WDZ’~Þ0×ç2šƒêIÎS66·c½"Ä×ÜFˆ’‡fòH /"%YÝK$ÅKÞ”¶<‚™Á~$In6Š@ON¸˜P!þ­?ÔU•V²OÕÞò¡Nâh•ö;²÷<¤rÓˬ›vË‘#`6àŒ:àܹ1Ýý(7v5ͦÇu(žYÌo¼âHAëòý­(7q’„ˆVV¥OŠjÏ ú1šx½:§õmØõÒÚßÀ/Œx¦|>huX‹Á3ªÎ@ŽÆCüuUà› ±w‹‰«Î1ö-ÔÂyZö /+‡]ä0N‡Ó¦Á‰k‘P2M@UiJáá1}#nPÚÏQÅOÜ(ïI’*^_IŸ%7À‚2Kvw—‹ÀŒ°DxÅØÌ71ÈÈSoÜ/족#l„ç®Åà«\Ÿ(Ör9õ=6è Ô©zØÓ~À¹†ÆÌ‰50O³ 3íA{#£BTCú=D1á©Ù&.jSp’–òð±RW›Ëí_AÄé7²òn†”àúbûH‡EÕ(‘MeÖ,L¡'£ín›ùþ+Õ I¹Ù8?³Öá—õ!©ž°ŠÁáònw̾IƒZY?´í¦9Õâ~->œÔc¦ϦSq?®¤„©fm¾\Ðí‘­ïÊÈh¥_ [íè •Í×¼¥Ùž¯Çu£Aõ³P´Ï7²Êr!¡Í6|‘¹î?î—o•1Ê0ù¸Ú¦Ct¤`ˆ,“" ÙÏ\ȹT¿ºëìÖ­‹q„—.Jë«–ïºÅJ›Ÿ©&}„FµEÐ>IºxX…ž¦cnâšñ+ ËÏ“W5f²¸´,‘f !Q• ŽûôîÌ„È_Œn{2qûr×r4¾#¦Þ¶ÇãŒÏKD*û–bê¸ nôí[—Ç{;Š,‘û[?Ty“ÿ[”´cÚþû5/-ˆœ€¬Á@õèö´ñKe«¡5Ûu|šÔS;¤­úÁRŒ &Ãï5ëÊ&Ö7™|õLh|n¢ŽJ#,ÔŒ \˜fì ôpR«Ù&Ϭ?fUèɘèlÛEwþLÒ¬Ð7Mx,ç!þ=GtAÀÐ(£=“UçÝP¿Ãœ®¥­gàVÇ`‘™€K¡»hAt€ f@CmSz§rñ 'ÈÿƒkŠnAŸSM—/@nádR×­Ý‹‹Ðj@Éÿ;¬É‚ëéaý´Ëxîì`|þÔjÕ±ç†%þ×cÙ´(QÚ»šÖ˜,N¦ƒá<¥š•§jTq ÃsUß>EùѾHØ\F S½ÖKŸzÇ9é<°vØÀÔ5,ˆ(´É_ÖÆ“i_Ý‹à¼TPåàÁadK=²ä°¸Ï4UÕã?÷CêËŽÅÇjIqÚ벩ÒBk?ÿRBÆÐ0<}é– '­otèáAf0ü'G§²j°º÷W¨P¹ª»Aœé’ S ƒm £Ræ¡i;zíQ/´®g´šsÁ~ÌÊáÙ§ÀåÖ˜©{ ýpϲGŸ‹ÑMô›3PLó*à $XKì î½^;Qßû· ò,_ËSD(×;»<{Ê:³M ØÏê“Vþjd«mjð±j$Tîñ~ÅC‰aÐ P@ÕübrÄç¸1Iìe5g˜»JR’ ÎáXWnQ¸Ý¥>f—„ÒQOñá‹€YGÛ·CÐaíæâ™æIYÓfM8œBzq²„ÕmG§ †¾Òm'~°¼á)9z[}’ã`šÄX¹%Y캱+@O‰Uêƒõ¶ÕYL»¤£¶Ô„)o{¢£þ „Øw ò‘›QU>œ˜nD é $%Xú­ÅM¹›ý1ΕzÄ3Õ—³«Ù\D¾0ÂûÛ|0ü'«8›S+Ÿ=õ· ™e-rº¡‰/T {Ø«+yrvqè Ì3 —›Š« “˜” –çuȲÒfŸž¸MžÌ™=ƒA+9á§•÷u_É+ë˃¦ô+ê7t“™„Iº‚”=4JZ’žÇ™viÚÏÞ~[Lx:û»,mýƒ‘ŒÂÌ·5ÇUô°¶Á±fB|öIÁe€(©M‡?²'´ðtë+-CêìD&HÅŠ+&/*©å«ƒ³ Ôã`ܳWµ¡ã¥…‘— %ÊS Èûñ’¥>7ω眲ÏÞ5‚Ó ©Y³ïWÌëwX£@@h;æNs…`=„«UîK]1]ÎTøÒÊnBÈv¦º@»YZ¹ö÷¯NšÀÖNª¸wósäåÄz_¤O(?¢<`Ô¼BwTiÚ~4…L¼ˆÂHcšæ×Ü×p¨()Úù[Œ7’/Àe{F ï%†Âxeh/€ÝcÄ]õ˜Éœ‘e¨Ïè  ÙSôN©Ÿà“ôýI…¸¾cÊJ@½‹£µ‰¯nn•@ÿ·Ðwq¤r,›zÖ¤Ãr}mП±EDœÐmdVŒ?øùqö¬#ÜåZ´ÅÙIqýëás£ÑR1ëäá³À9ë’ü ¿‚fð‹Èlk&MNbÊÏqÇ7כǾòXþÍ~M2%=ëæ+·Ú÷L0œœXAl®WÝö±l¨Íz´]h†IŒ9t5ó3èçjÈÚæó}V‘DwÙ´žÑVÁç‰ ~óáY”’¶§^d%Í ¸R—e|þsr´9@¼ÕO÷" mù¿p©® ›ÍÝ©ÿ2ŸnÔÕ¹eäHe_r¬ÍI¹fBa 塊¼ˆå“žKÐÂ:A(¢Í.ÌÞ¨V­[Í#ÅÌþ‚ )úˆ5 ð‹S<ÈÏIxäìq£T1þH×KvѤÍ{¯K –%ç¹p輈°t=íêê¶y‚ñkƒ´Öä>žæ–f˜tm9°µ@×ãQà[ ö¢ÞÜ#JC‰É©²3äŽ9ºVïä0ÇÁˆ‹jsƒuCJcºëFކ¹ ]Z`‘ÿKµ^ÆUg©ÝÛùK‡iÐ3¸ú̘¿“˜en¼;`mDdÝ„èØýïð“BH´lȉ®j7ikÏÇA"n'öl` ¦Fñ]˜·m«­tgaž«#ÀLÀŠBv…[dDʘ¨£Öxó4ñ|õZ^w< E,*¡69gñ%í¹µ<Ÿ4½–¼)©¶JôÂ?,ÈôFLè^‰A)C4*°†Ó<&·ôi‰Êœ¸Œ½ù ¦³]ѵÕìíýæm8g£§‹[ð4SWñÅH£DÀàæz²òß1ñ¤þ°5æ#Ãp8 …·£bŠVnêq~¨´œš›Â+Â܈ýeßôfÜ|)…ˆ†¦²¶E­½ ÍÞpËá4‘¼‹`ÔÎ+‰8·°Ð9Tÿ¥oMל Ý+Œ— î YˆÔ—èVeN7ç ÊQ@ù*1ÝÛ”_°ý˜1W¡,Èœaª‚OdïÁôˆoOK­¢{Ü(ñ¡»WßúN#‹Wˆ_2©ÙZØVIrÅåÃB¦»Ãrñª‹}²æÁ|‡¦p@­ØÐìN ázÅÒ˜ç¯j‰4Mñܱ&B0éJ1¦õ„ !ÕÞ>éÄrèh¹´‹ÙÐrSj:îƒCϱ¢§išê"(æ1¯I|DŒ 1.®;¦ØtBíõ"SŽ"‹‚û¥L±Üy7Öø æƒXTË«g³óÐ&û‚Žzш脅¹ýgÄÉ—î7ÄëN'úÉf±é†“ò¹«!ÅÂ<^|Ï“¦öäŸoðA·"7”Ⱥ¶‚vÑÂØuœçc _°}Vh‡C½ÏhkwðA‚ПÁñbj°ÑGºÉ¾ðÔ1Ï5‰¨_4ƒuÕÀ/ÚRgV2 2‡é¼ßkÑ~‰_êmÒÐ ·döxë¿ "´e­óœ…nMí×{—et|…§Šç| òsdÆðê+” 36_ü<ëÝz’Æ#HcÔéÀÅ7¤$/«±ÈZøN”Wµ ×O|P½½_íÞAbO~¯œ€ÆN“(M§ˆ´¬_äß|À3^ë`Žú|ÚUÀ(DþôsìH(¨F(Ž¿…q•|rQ•¶˜§i»ç(Vûù_¯q¼°3 ‡šÒ:, Õ›šbL}8âyRØ$¾ÏGÔ) aº1D”ÏÜÃv]ýÀ&ý9]Æ}ì{1=0/2ÄuÕm0÷ÇE’…šbÑ„+1­ÇÜ;}3ˆëÀâc¸”rýR*á ÓOä¶Ï¤T¥Ù&7Wî9ôvÖ$lžúþfx׋±0y¢[Ô¢ØuKìŸà4ƒÞ$ÜB³o÷ê¿–¦+ʤ(«Ñ‚êI§È±¥\'¦LVrªðÅXÞ"Ñ„SUž_`<*2¸{^Å” ¦\$Ak¿ð<:íÈn«Cé¡_~°&l뿤šÁç–>–ÈOAæðË£cßÜRØíòÙZyn<¶õÐ÷òµ…s? ±ÿ»y@§s«äÓ^-s¿Rlxñ?)LY\”Ga¬ÁV¶—î,wÔN©H3½7 ̸ñªfÓÕ‹Ýý¾,IƒÜàØÙîZ­íMsT¾…M>§Æ)*xðÉj1‹ùá•óÍ'1 óß'(Ô(A¤-ü1ðkd¸œûHP¾Asݼï#‚‰ÐöÑ©5Bdr|õéüDðø¥ÿá=9±ûë´ÏI:ˆ=Ù¬ eÌ~v$Ô}‚%^ì:–ÞL‡»Ûì'÷üûÐQPÆ üoWÿÈö–Ÿ GŒN€]ê\¡~ ª¬ì̡‰5ÑÌÕÍú®€û"è èþ;%+Eç ÏëvQW¾Ð Ào$DzV&cÁ9à/~”6ø¨[ºEy¾“¿aúF2""ááÔÝáCȸ°*¡PM'‹[p_ŽõŠô!Ùvýsì½ýf@±#iC/~÷ÜYÓ³*F¤»à³Z8<ܯ~Žç¥õЬ4ð ~X੓ƸŸªbqÐv†£‡ƒ®œœ'±!Ò§inŸ¬]&º„SižÐ=ÙˆÕ|-XyŽh"­OYÃpÏ‘„X‡[|à˜ï¾A¢»Š"æÕ”§èø!õeö7óäï L°Î_%×Ì>°bg¼a?0¨ØMƒaTÇqkM Î³*‰oV x?³vì¶ø_rHº„…³ÿÀå¼\7†ßÄ|ÁûMÌ. ±ôaÏ òCµÿ‹P_±û,€{žÝB¼YÍè"†(HÄ÷PEz(f4TŽr&ÜÞÇ‹‰ª P£F ðùYóJç,ýÙÔœSG[Ìg²Å9:Xya‚óK’únßÛ§!Õ#¿©ùȰ¾ ‰1bÄ»ãÇXu¥œLı“µö>ú\¡ôeÁå9ø—‡uy%³xž'~Ví½Ÿá †Wí²@­´ U "0*UÑ)–yÅ¥˜3W¿íþ*ýñÕ Þ¸¥#¼wb¢§C÷öé!­ƒ»¡ƒ¯  wNÙJHñ¹"°xÔüFr¼§öDzÅWPÏ“¢3Ù&ÆýÔ÷5ÏS34·pyê jGΰxK"dü˜S¦Î"4SLÐÚù­¡'Ly‹Ñ‡1—¹,q~ô ž´ÎÐXaúÂÉRA½Î±ú?y73&gƒ¤ Î`1o}È;§dËþ• ‡D%Xwmg;RÉ‚.]éÛn~Þ‰Íʶgˆ1°Õç÷0÷· o~š²EÐY'ø«»ò[bU}!á¸ËdqŸ¦Ÿ´ÜÀ‚2ӇКK?"}øÜ®›O²Vþ © 0g˥ŠúÍ lø »ÐI8W|Ò(÷ÎDÀg⻘UÊòdüS*Š¢P!¢l(õÿ!^}Ñôј\kÍ´îY7­&áÁÝÿ[¢,Û¸ÐÏèi½ Aë8'.ü¯Àsâ}ìÙ“¸¨¬òôŽÉµKkNáÜ"±lÒßDf/`x]g5‚)E€·¿N˜B÷£ù¤æô%u)ìj~È—yU{„W€"°J ¦•#Î^¶…E‰Ì,:‘Çüƽ“ÀgÅ£Ž˜•B‹Ë€A8ˆÊ­ž9màQXÛ²ü]§97U™ôz:/Çrb×ÿþ¼­/Y dG±#­gó·d4â e¤âbáÛcÐ&;TªgÀ>ƒ"ç‘‘ Î$ʶˆEY?I9رv¨e0Y÷+³* ËÈV„÷ åê¬OyGE$¾÷†w—*ø+=ñ$4£ÅÍ‚‘#OG’Ú«x©wdUŽæfJvÚ|Äoy±\¨ÝbÃMåkxvî†7ôG…ô‰¿à†ÿäjgó玱2¼g~¤oúg]ÞÀÿc(’¶õ—Ê}ú€XDpkû ÿZ/ôêÈ™é 6œ8ø¼±Ú¯²H K@ ÒuùA‹ U@i‚{A8)ÿó]£SÙ+™¼‘»Dó/¥=ÃK!Í”‘ÊÓ”- ±“nYcË5_Ž¿ê‘¾”â»L¸––ãP…'Ïm»]º !îäÃioÏž“ bb@XçÖ¤ž)þ¡úXЧjŒWå\b.dŸû<"Ý ”~™¢è´ç”„QÓâ)—c(„öŽe0h%&ŠH]8¦„2Œ"hÿÁ~]”"ñÎ+‚ä» 9½a1 Föm UÕòÅ´ä?P­p®Ûx%öô®Û¬ØÞ~f,wRñÁÆ©Áéñ¿ ².#zW-dê²?ÈÓ™<¼E/VnÆÓLjeѽ3CâЮ‹%àSÄ˼9¡õs=*-ø©QZíÍ%+©P_IŠŒÄ;möÑ¿i}JéÏÙw ~Oíß~͸Šçó3h5m‘x‰û‹áyGø>ž¢h$iË!(3›ý눰 à¿«E[@¯Ye·¦ïÚíuÀ3œ·u®}_Y¦FÏEtÕC\óô#ŽÛRKÅ›üs‰íBÛ¾[졨x…/oç™jªJÍ:oQç"í¤e3|( ÈĘÂ`M?e3@#Xc]b…Û‡#Y8’KSÖ@ˬ~lG‰+ôLøØ£§û<^ÒoŸiÍ—E–@’#†Ÿ j Ø*KØ´4Ò½+0 ØyŸšo=ܬÍî˜Jo2.³»:ù¯Jq¶€g÷*nçkÙgþ¥æg…çk_¸—ô2½àS­o;îò×@ÑÆ^¬ÍÝŽ"éÀâ­IN„ù'=Ì9ö)˜³Wy®è¸b†B–°Ž–aè­¥oIÕÛ&•ûòb›ÅN™kTãg#’ƒ¤£Ü6DZõ‹™k<&uNå‹õGñ¡­Îô×d«E=ÙI³yÖYÙ0Ý#ü¿E½,v%¤Oæ•M=¶|„.SŸå(áfØ®šíàG5Uyσ?h§Y§ÐåÃóÿ©Øœ¼z =ÇÔœõãe݇ 5S¿¤loÒOlàp2¾)¾™Ýø?"³x½onäudÿ=KFtÁz >æ»äð4Xc4…(àõÖ¾ì”Tª'RÁhhQ¦Ów@ì'n4èR;ÿ‰Ôã’&ˆ#J¹OÐ~I=[ØVfœ_v“‡ ~´ó<öýwC%é;5Hfþâõɯ6-0r°éÏa’ˆ.*êXŽª˜ML…ˆ;xÜ“¡¤õ O1M©Ø <S”‚t†\À;wmȞŃ{Â=Ë@N•#቎™aÀÌœs%è»ir’üÍüé#|Sè.“·íA~]u‹rž#·Ñ¹oQËæQššîÌÏÉFUc½=OåÌéæÃ"”0ÉsŒŸlIqTûºIÑP.Œ“¨?ÙŽe§Jÿ– }Y/±WY2:ë’Ü%¾ƒ}Yõüý†kòá†Cø–³2[#NhÊTÅÂuŸEUŸlW;4æîyñ¶êÒ¶à+æÀˆ!K)›W")òör û U eX›Ô$¾ ê/ƒª°Wb*o¸Þ­~Xj˜ØçH&é÷eÿFŸjª_ h»¬ÐÉ€„a7{ÈÄUwôÙD“7w¿]ËÞ|áƒîzRDøyМïo£.²Hý‡ÕŒŒÄ립wA ;”±*0™:.òjN#2(ÃÎcˆ$.¶ÖšV$L.',C¬Öi~®’NÁ^ÞðÏJ)ÃwX6%4¡3—1üË„m‹ý¤!lʘ©Ž¸M‚7ém¤z"’˜7§/9 ‹ùMU+”×’€lõ‡úÞRYÔÚZyö1O´m4_*ì¼Sµ ¶Uh’ ÕÔË!…6Ë8éÿÇ%Q=§½‡yÜ/éþ%P!p`V¦ýDinL‰”Dñ‚ÿA{ìÁå>éj&¥Õñ@NGp7¢kéß ÀT…ûjÝ0¥­¤wDÇNÊ!*O¯rÔ˜íÊy¥Íëƒ ƒ;Ìј6EŠYuû¨Øì-¼ïå¿w=¼¤ Ãpçk<æãu‰p‰ew:qÿ|?øÅ—š®°†8 è~Êûm”wÜ”â
ŠÖ]T¤g7YðˆÏ2šþ5ºJ%Tj‡ä†w¶‘ÍmÎÙÕ³ÏwÕ£?”Ÿtœ» âI{Fñšhÿ0 "‡UJfì¼”Ö¢¥Å4WQÄü'W„Ü5³r¯(æ‰Ð缫7Rñóî¡yqÙÈEàpH ?Ÿ÷¶êÖÿ[X2ÁC§Þ!íèiÑþŸ$r!`5E.;¶ßY àJ%à‘ä.åãÛUÕšBörD1QÀ‹Áø·½ÀÄ‘rSõðqEc)±Ýx“<'6Å(I{áû„ĉlf+v6|Dq¥ËÀ>Á›bÊZIÏ3í“r“éH¥9áªew )òKª³ ÔáK=Ò~c©eC&6L“Çòb|‰4”Û°;‹·ÿ•Y aD{Ç#(Æê ×+›“¼ÚUÔ Í/‰pïU;öRVñJøWÎt­éhÄ¢vÀõÑ8èô»Þ‘}W^õ[£Æ`«ˆºU#WÄ[âpôƒô#®CZ¦ Xôýõ)øØ –(•îPÏLI°7kTI@3—?ËÚÊ Ð”^’ðê7­3SŠºÌKØùSH—’7 ó»HMÞG…×Ê*d *ýMû¯ìäÿ¬Å@8D¼Q¦/¢=àX§«¶ˆ`}°ùޏc©é·®ßc$°3-¹5©EÀÝEÈH„­Sáfð>Ëæ"odsTÊ¢Ï Žsÿ§¸üø÷¥ÐâD®£ŠN%õÁéø,/sS.•²õúÊèÑ?ËÝgå¹p1ÄvýVÃéZ¯ ù?EÄÀõE«ç7(bcÂ1rf=üà&t ¿f-ÃN¥D£¦Ûì†òBï‰(v†l¦Yó ȵ`*üæ?ÔsVxl²äeêß²;•'ç°ÊÔ¡¹çœ§ó§v*e•3ô€¹Ñ ¨à Z& OhÐîAö‹î±ì¦<ž fKÖ<1ÔãÄž\š–ú§1Sá,2Y¿A+•d.ÃìEÛ_ ÅÐbƒ WalP§Y‚MqøéÀJ_Μ>(ÄJòŽÆüt?r•“÷ÑC-¶ mZ‹E6³iÇ6f5]çñ€@™¯™F™ßÿ&SOòÇÎöÿ¿øeô:è÷ø :§4R òbd¸uðÎY·†Ô¡8x*¯áêœiìÊsEF¢5boîFÒÈà)ÃÞ}ˆ×H§«ž¼ÓËͼ5ˆRü烿b9gî§­KgŽ\}P®á}ƒ’‚RÿП$ÛŸˆÈ7Š&= ºEæzUÝœ}ItA"­ñÚßSuØÝê—JÖ¦¸…0„J ožÜSh1øºTس¾}*ïB:!Û¬Œæ‚ €Î£­¸ž]a²~á£ÕŸ'+HXÍ)´3[$þ{ÅœBsÒ«¤»zN/! BÞ³~mÜÒÇ9éB%sâÌÁŸS:Õ!ÛÆ—>³áå}´á¦clÞ64­ærBë 4=œ ~àøaÁÕm Â`Ñr”µ°BÚà×®*íDhg[dŒPLãL†wnéœv¯ÖÐþÔz9—„uξ¾t© žÀ…¥~YÍRg—øB–øl~öËà}NE}3G>ÚTð øùÇÄ“nFCò°—GÕ/Z²ËÜõ9ˆÛsí´ÅQd‡íL §0 ¶(ç#ˆ-¸)ƒJ8,ÖX‘>w4Ò ’É&Þas>µXÄŠ¼r.qL³× ؾ/åØÙʦòw–l —”» ,ŸíŸn¿6T‹ '>xEñs™»m]IP¡“›ý&0ÿ ÌÓ¦× ™x¯;€®PŸú)ùºþÁË2…¹¿½iHŸÕWàŠ¡9dÕßWìZjÆW\åLW 7Hµ÷’€Ÿù¿µ­ë (rš¡ ±¯õY‹*¾HC­.l¨-)ã”Z…°;!ÛMÒDÃ||ºØªÚ¾ƒ0޹È0nr(A¾t9s€6­ºâêv;º4–þîãüñ­iG²Vj‘!F/‹‚ùaê¼^h{݂Ĩ£#âÔuZPt¥õdíQ „¤Ì¨Gºn{Mv1^Ù ý3•„£ƒ(âèÕØú/s:M DɵMõìã]!iCBD:69ÑöÆ<|ØÜbJi‹,‰+ éÉÆç_¢õ°á”ðül×úZ¡CIúϽ•°ç>+Ì´.“Xü ”Ô=ê¾iÐ+¡Š¹„é0Á0ó:£UhÃø¬QRSÆåçí9×ì ~?· MyF™¡¤;üŽköcøEX›:B|wþ£>÷Ö0cy{‡Ða~ðrK$ƒõ,©gû 5‚°”ša/"·…Òp}¡¬iæMÅ‚«1ì… ±Çÿ¨‹5Í"£Û‡sÇ ž‚‚ºê¡Hðz¼æ¯Ñ4Üwóе2G1F1ö @òÎ^ÏÕ÷ÖLÕ“ŸÆ+÷þ·§PØÌl°“é´ÿ)š´ø†­a%òõÆüy‚2®úÛNÒÏO£·ŸÜÊÄ@$`s,ûÔuš)&è*§j§²jpÓëc³“7ííë "çž„9Õ<ìò{fÊl¤#ÛFñëÁ›:e—õ«ÄLâCºµ ÌÑš¬Aœ±ò²1-ÙŽB±ºtýu‚Åwõ.s™ýºRçe",õpòž€€E%P*HfmÄ• Çýzãú‡–'ó‹Y”ŸËfœ†çNÒ¥Æ{Žh{éw‘äVÙݸìÁ¶}Ÿ•£< ÕŒC'<Ýk“œLªÜ9\?Ê4ð¿hqïcJlĘsEiˆÛ× •—¹Bú;Çêê(¶.Ë÷p*¶Ð‡c˜‹î5¤›ôÝçúeŠØ9Vb“ˆÏv,Ë‘ÅЯÛ¿²ÌÚ@aDgnLQÓ²e_<@4iì¨üÎ<DZ›Iˆ×M 4 >ɆX ʵÊjñqI·çw3«"Óå} R’![u—zW­)ÇÚÝ$Üiâî*œÍ¬šô{”¥± Øâ=^öþ2{wÉYpô?—S»’“Üvx½:D­ªÛÞ¿rP%{©µÅæ—ÄnÒQ±7ô97kâ{L+ëE)c ÁN?Æm@k&V·¡)b柊éÕ­€‡#ÐQ~,$pî¥MÈÆúçα^MÇà-˜&o*…M °9?Ð52L?xi˜Mò"0ø+ûU€‹c#žBId¥|@kú·wÃ$çÐü`_†DµV…&¦‹ö&»l_àÙá.üù{âSß”·Cøj Ešhøu:Öäù__ªúî8gŒùМ BhD bòøúyQ,>yU -.¢£y°Ð7„‹;ÈÞ†OÕ 0S6W„KåŠi`†3ÂýobˆùëŽ7ÌÌ ‘&Ö다ÃÈ󑬋Hvˆ´{¡ÄŸÆ:|¯z’ÌÞª­MÞÂ5oÂSÝ–æÜ$V'ýýÄ難–õÇU=0}Z¨°Hã8Î!°l‡K·(8°T ÉÀÛmÖ¦ÔúeoÐouatûQïlëŽNë"”ºë)£"Fת»Ð9SŸ§W÷ÍÅ \šYV•Ê™«&b×±ôŠíƒ³Ë´P»¾®¡Œ’‚ÏL¶M´È€XïØEËý,?sL çn8cŸë/"ŠtGR#ücQÍÑ Kc5œW7sê†o;q±OqmêØ€q1ß[•f/ Ç‚³U‚^FWÌVp’xsI;x "úZ㬵ÓRSŸ½%fzHÞë6b¼îd7'iÛÑ™­ï3Á^õ;eN ðûé#Ì{ÙµB>k‰j:'ãeO¾è/ qóB«IßjÕØçü$€*ܳ·ø¾ÚuõÑÜ¿·#ÒgÍn/–²´,¹F– c­IA—x`¤cØn¶:è@ráB®Bg›Ýd©à& 9JXƒö ¯uBæ]ü°øWÐa$G%7%"Ç{RÂOzWÄçMÍåë‚ÅÇÝ u®«j½gôFÓ Mã#ÒV€šåXÖÎ[È9ǀ͚2¼ùX%{‘ï2–¿3OEç¯(u’Z„…(î³ÿŸ¨ùP½xì_uÌkóË«kƒƒyXeƒv6¨†’+ID.Do–5èÍ´I}vï_úÖ[~ä%A\‹CIu7ô•zuä’Àµ¥«˜X3VCï›”XÊAöNŽíTÔµcoàxúþ1]Ü0kz™Ï˜rÑqC*Å_Õ «$2ãR¢ñ„éX 8ì%²¦>AÎÐã‘gö£ßF%¤çnŽÍí‡Æ ñ»sF qQ‡™Q\FT6—°]ÆwC‰¥[ë÷ì<ñ6=J÷L>L¸¥S$ÅÔ/ªWØZUÝËÈÏ4%¡ÖÆ8œ‹6Ö}©`EåTÉ«Ÿž˜g-Ø4Y„b '¼?Yù‘ÿÑc]ˆíÿú wšîC\¬§bŠY§×%¸¿ i jÝl(ïIUÄr'àâxûÁ,iqµ”¦òDãÜËFiâ}gïô•'%ƈ;9ÆP“ÇHXÓy˺™±ÁW,%‹Ý"ôq‚6ÁEóä¡qø~Ø­ºRàíç†C°¼¤¹Â²ßµˆ_iË„œJbù¯’ïZ Dy¸D³R›Õi­å‰X…q㓵œ?¶ÕZ–-k½‡ÆlnüçUN+SÙ3¥;‹½®xÀ¢?×ö lS¼„½ÁÄZ3¹¨KšŒÿ™«'å6^ú yV)Ügcî.Aéò«í´ç$ÆØ5ܱ*Ób R4ãk£©¬rIG ¬úý4ÃÖîÛ4›ú$xǧCx*õ¼,­{{R½6Ù)HA¶näí?m¾¢»£¶\£N^‡JÞõË:)uúÛ])Iœ¾è| ᜽ũñ¤­É²Xæ/1•-’(ÿÈU,T»1$ï&âˆAiPæ-÷ÌyFN/'Ó±0;aóîïËÀ‚e/¨­åMÄ쫛؄?“¶!€…s±²ò-  ÈÓhL›ÿ—f"ŽþÅjÉpYT7}5óÚ$ Ù$Á¶6!lnÍ—ßg± ŠÃñkPGádïxMÌpa×%ºî<¸U2Õ¯,îΊ١Tu|ç~g¼ë`má†6Þ¤„ìßÕ‰ÙpÊ$ÞqÞ&1nùgmu>óÜ­‰Í|ÍÉð™.*›WÉ©åH¸V” ¨:xRï'j[6ˆÕö!j‘+šX¾=÷Ý^$T<4¯ ÐjÍ«Tƒwx‰ç¬îÌ`5>CÁ–?¦+Ѩ£”;W­'—¼Ë…Eã\,èµ}­¡¶#)î­ðƒq6l»j±/ìNÑ'^ Êð«ÉêrƒzÛ|¦nT¨à4";æÑPŒÔ7ó_F•$•Ø|”µ ?R)q̼x,°ÐT©>²$þÎúœ2ùÇU›Ë£óå(ãèÁp©&dí«DÓL[ì£ / #Ú¤ˆ3Güè’Ä@ŒäÍ5ò:±z›Mö­u³½5^;¸ª(üù;|ö· ÆHÁh‘WQ¸û>Á#‹f$º@‹ ´ê¸ç‡0S¹W¼vêçn’ÐjRû3d-c7䀆þâhøßh•rª¯àâðòðõ.—÷3.ßIXYäõ Œ„0ð˯~Ì–Èáoªœö §‘ËÞqòTÕ‘”¹ÈÖ¬ÜaŠB)3çQVpø“rŠ=0ÆkT1³õä·w9™Íf­6ë„ '-úÞ¢°ÎELȱ€ÌÔHÐ=)žÜ˜– •’Ï ûziyO_Ÿ‘•ØŸ$ç·G±žû,ð¬ÿ•KìÐ/Æ›£ùî?ò}ôÄ/ùû——Ò4! fïy.Gš­k½øñ…›†„Õfí°b¿dØêh¥u'†¾úP=p9É'Á|ª_28Ô‡eào5;óœÓú!=xJc7&œèÈŠùd Oí4}ôæÁKÙB]ùb÷XÜó4­´@.´°Ü‰]ë h!Àœ~YdF·ùWEPkhˆïžZŠNµžÎ¼«o ªŸ(:£Z\ÎzÈ 1 Äl€X³s¤ãž½=âB´¥ì}o"`õ"½ƒAÌâ{Ì*nü£&<Ë•Åfºîã’=ômQ Œ Gü‡Áǹšôíi¶cis-=wÍ€ñ?ä¢õ D*FC’¡R«ä¼ÿJ¨óm7JáVF À›Mÿ:ôHš™4!ø¶Ÿ1B<í—ÊQLnÁãÄÑ1¢âÎN»+5ùzAy& yô»œkÕÃÀBϵé[7ù¯QU.•ÁØZžZeƒ»ô0CÍ/OÞŸkû¡‘u¥Ks¾d2Ÿ'˜£núàL̈¦(Gß¶gN^ñŽßaAéÉ>ôÄV*ø8öšü BjÇM'=°< b?Ï$—7´qW82T—ºpR‹÷ýíд¶Xœ¯€V h0ãfÝ+M–k¹8pÍSùñ¥g©¹P_uB&×Yc28I¼y ¶HYb°Mê٣ɞ´û%jC‘·y"lþòëÚ)ù¼bÜÿ—›B&²Sn­OëYÊ«glíóí°9¸…s}êQn1mi 2ÿ¿LΣålL¤çLÝìc ‘Í­Òø²gS![¥¨Ö+ÕHýüÑáj¨Ù˜iKç+)D§Ê[œp»ÙÃéâí6§ŸšÎž*ÚžØK,Z°ŽàfËCÑÙ³I5Gý©¸¼ ZE¦ñÀæYAòÕ=Ø&!P,í$gÿÖœºÆzÈU"ûÀTÎÇOk£¹цBñ“s•é<m±•‰\Uz·úñçšEØ4¹¬á3(¶´óœ²R‹MÿUˆt¢Å¨^ó&w#Jëv`´]·5ÑíÍ¡²¦LùÚgaŸq Þ±V“Èài¦^ÔoÛŒÆsĵ&ïXÌ´­(Ü­„@è.)ž6Tòüø… p»n®´£¨|[Ah `£éÏ¡ù X¾–»wjïv÷ˆ ûF¼ÈkÒ–&+sJŽ]Ì®j%[úUvV^f:u´NXFm·Ó²ÿÚ}ðHà>Û-Bm3‚fÓ˜CsgÚ1_18áÑ0¥HÂPW’iÂ08ÕmðAøª$:wÞP×RÏ@í]ŽÛý”¬@ªÜsÆ“›âïûÞMÂ2—)åü&´h7IBSh33*½Þð•ÙÌݱ#œgÌÿCÔÓY)MµÛr8—d¼òNÜ#йbŠ`y…®KÞh®Þ˜Â²’tÜe¡¢- Ó NQ¿Ç‡¡ p;[èùP7ÔYMÊÀtÖZ7UÒ¹bùo ¬Îðó_rÒÂ-©Ó?ÖX nß0@ŒîSl­ßXŠem¦› OR•7¦à› Ö^-Ãeâ(ª–`Ø•ÔK­–ÿšV¦¬ŠwLèJ,¼µB.×TŒG´G_kôN¨ÁUAÐ6Žß;.d툘”Ží Ìþ6Ö³ˆÿ:Ž+šå#ÉùJ2/E£Íºmý‡ÀøÝ, ´K³AwrRôWáÇk‘ÊL+q,þÇ1 Sé2LÑ“«Ü5¤|·q‹UJ9È7çç§Û¯Tâ7×-^Í8噕Ö>„@ÁèAävfªO o{äoÃ%˸Oã‚(ŽÐ“-OCuŒpdÃ…†˜zb¬f(uÛ‚ù÷ ûã® †Þ»Œx×ç— „)7Çð;'™‚eÇÎ,{&ŽQXI{š72[hfg61lGÛ þ„¢¼6b_’ç×¥/:¸?Ï _еBÆ[£¾ãÚ¯ –ÅǨ˜¾Ü·ñI§ºÁÀivÿ"ý>œïjiÃÛ» €5Ù?8ŠÂK5ï[鮼s…w´v°tP÷cÖÆy² `=ÎD54åºëîWQô©Äý’ë8¤eÛÞ}Ï򢧮™+tB)¨Tœ¨,¾ÏjêzEăä.ÕŠ-/ÄÉ©4Ï¡¸Ó3<í÷¼!-Õd+Ö³ ñ»(®óŸvŠfë‹FãsšõvųèA8“2Ûjê~çæBÁ/+ÀÑ“ûЬèàñ-B’[Pëͼûì=]±J-´‰ÖÔF£ ’_9E¬YE7 )ô7”@¡¥O ˜Ü“hûa,˽yž­x jÅÀ̧«pmdA•8ÇŠõ\Y® rRØ?Ø&ƒ ;DLD,«´A=„Ÿ@'?„ƒÈE-ê·HÐ}`^Ü™¶¡— `ºÍwr’Ÿ&@T#¹¨OÚ[y¥«ðc®UòIj d¥–~ݽðµò×1YÎÄáQël+ q¼¥Û¥Ñ¥>#H:. ëÜÜŠÒ‚L<Õ½…/FG‚  µÇ亪Pplµ^Ås±X”MÉõÝäjëàÜLÚU=øŸÍ”ÆûOeÄnàâd9íµ%¸ƒ+ô ¢U²ºù ó?ÿ§ãŠUuŸ‰Ê J¹àÉ}äNxö±ÎlìèÎ4ÈÝ>áÿ£/Z×9ùÒrZŽHÒ‘B6ÆPÅB†ÏÞQ2jsM?m5ó|5œyŽ“˜Î j¦béŒ ¤ºŠ\‡î 3ž>H'®>O–ö‚Ò¼IŽæ»ª‰÷K•êA *íôHɪM‡8¶Ò}y˜¸‘“Á–E>ïþuÞI]”¥/7+é<ÆëIFx.N‡¶b÷Üò öÊÒ9÷Xý#–e¼¾Òܨ¼¡±æêú¨Rç´ëJA»Ð:ÆžÖ†~ ÅÙ䇔Rç̃ì£ÏxQðÈ;Ž[‘Û•õ ÂÊ»Aõþ¯Li&›”jåax‚(~F-$)­áK¶©é•w}ÈT†ƒú„–3|yó˜0ºlÛ?ÿ˜å¸™ø/‘<ü*e"—Qû¯º`z¬”£±ßЩI0À˜`2oÊ—_\×I‡ÈkŠÚðŠ8R0ú_“ư `¹~™=~ªÁ‹|Ï aprìÊ0TÓ›$ú^ ý?sËS™a¤øÑ­…¿Œ@ZЭJ¹TÝ’BÞ öà-¿ÆòÇpOÉ’gGtǦP„ÎÌwS]âø’#<¥C‡VOf86•ò\5&y ¿º5öèG¼S?x²H¤yè`H¡Éy»T}˜iÊèwî÷K¨,–­{£a‘‡©ØÜVÇ«äÑчJß(ç-=1êp…Da\SNëë™=(F7ŪÖË+ºë¶eW* °.1s‡F3”àÊ7y:lWªœ†Ò|ŠI¥Â¾ZçO>{´Ž»1\3Wi§Aßµ‹ñ›/­—`Ægåþo¿[¦h›z`&šUš­ÍܰK`7X.$Ô¦(nÁ Éݵcî?@ê[ý]L»G³ü…-R¨)Ve0L¿×gŽWîô’à V»oØñýõe°_†î9¦BOêNɲÓα”©5Rrw0g¥X›9•–¨‹NêVŠˆè¬€ªñ€d¡ü*|É+±½³Nœ *üÞ]•Á×;‡ÿ½šêäN 4­µfÐoàû.Ô6yE1B°Ò\¬P®iˆÅc&,ŠïéOÔ£&\sä$_ÔÑm2•÷‡¤ ü•ÎÞÇ+K>ÄñÐÈZƒO–´Œò³p ò&’9×—Þ+E³à¦cû›?­öÃÌ×g]Ÿ´ Ø_UDŠñNè狈‡*Ol¬®|ÏMNõÒD§!-_qð–»é^€eÉΈÝr•·šä5ô« ˜­hU§“¤~`R°@¡oÔáÙú^‘!q)4`• )ë¸î—rM—if:síîÑJ<ä¶>¬+V¯-¹ªˆçExJâ5¶D{Û%jï‡r:¡»ìBÃîõ?c87Ñt¨èîØŸbË sÛ6ôÏUhD=Ò˜ç½SôuÅAšöcU:ß»åx‚oö<ïÓTãRö.üJ êª|½_,èoÕ¹C&,Ó»ÀÖ+Z_Éñ8…üµ•údwBz #òªmEã­ṳ̀Í,2ç=Ü:|Ýoy^T]b"“Éù™L„KØùjWÈÁÖpA5B$ßX$ŽdÙž€æKÐè5Ib1a#ÙºFøÏ›ŒØ&íÌ-%n }í~~1”kcÜ*uýØšñ¤Y¤b;[u_ŒçÔ¶% œÀ…ÖcŽ\T|ŽS Ê!±:%(œùqIÇ“ú3ó*C+Ô -u`l§ºž¬Ë[FqЉµå‚ “mòŽ g!õñ+îLV "Á-QTÐÀ2÷ït”$&…’·z²¬ ×‰Š–Ö óúdÂ+7Ï×óýæ'zí„ó¡œæ+CT$¯UwªCwè}¼¨Ýc&v£Â…eºÆöuª™ zËäÈúª¢ù0Ýádſ٩‚¾ƒ£Ký'ðuƒ>™ÖpKܲõê;±!Ô X„Sq`T€9NTñ;±1kâFÒÐ>|gä™eÚÒdaЂu,2G) âW§ÿ6lgD ‚4Mó€ `×M.3·Ço-S"»)’8”#ïoiŒØ\I£.·ÛénªÂuÚ‚ŠÞê“Íl6fYfA=Áã",†ºR#mP2Và§1´Òˆ™¶±9œ½P½Qü–ß/Ÿz¬äHîä¬TJ¯f /ô¸*•Óö­!ä¨bôx°Ö×Eùï_'ņ.:[Äéòt.%¥_e,áQÒÌÊFÎ æYy3ܯtyvŽNLˆ:Dj•Ny`Ñv‡ló›µÝÝ¥HÕÑá®lÞG|yÂô9N6˜~…-ÍF›$8AÎÌpç¨MvÒ‚ C2ÀÊsD­yÄÝpƒ°¯ë´B-°Kº‰˜r÷98Á8œmø/?{Ø»h–ءʲûÇréá1hšWÃ1âR[>.´ÆÿzSÝ,ÊÔ¸§o §C)±[pººFúA{×·¦Y¦DT[åh$¹R8À¯x™öèAãÁ_6#B"t\ÐQÍé­³¯¨…‹½<•Ö. W9 3AŸïsBßÝ‹ëH/Ût)Sl¼;¶¥h5ãή٨èÒÚ Öß™­¾õ‰²½Xc­ÍXM&–/²Üa´õvM †h¾h–Ôl›‚ÕÑATIÞF5àî&m<Š!£ÓÛ¸×ᦒâq.c]Z>í|ë±\X=GF íO®Hâi¢öˆ” ¿íf³M´XÂ~ü07ª­©Š€Þ¨Oõ¦ú) F‚Ä\ÄèmÆ<“1í! ¯#…M`¤†ñkLï5R¥ͳ½N)p£·‘2îg¡¯¤Šy•­ú’¾xªÌ(éŠK6ø<êB®â•Š=Kÿ´9~4×5ʳÝ]h™5ò»Ý“@O=G¼nhWUÒ]’=qËz@×ö'„¤Ô!„ ’ל2Ý)¶Èºk£ý²éAO”´‹µªiX<7Y'/iBý9 |ª‡ß×FŒU–Liºu/¾Èòû`ÐÎt%²·G{ºRõî»aŽî0D8w}Žiw àVðbqþž l\™ý;õQ&5°¼šÎ±r-1‚Ž93÷<-=M‹„o³ÝØR‰ÂK}È2šPªiè"”ô©¹tÄ!ÚX 3à¼@çÀ2 KAÆ_¸n|ð‹mìæ¬º1V#JxøÎi6çRÉÄ•8èN"`Pçrö­³x¹ ;Xydùì)Ôȶžø’h´ÆÁó²Fû΢•ÿ"­£`bºS¤Çê¹|:êõ yÓ/a–5ˆ8èЬ*L7ôü;ýxœo<ç+NÌ©§Ù?Ñr¶ ºÁ-‹TÙ5‰ÏÛß— ì>I1Î÷æík26Qé6¶sñžMJ׉ò4+‚rĉá 3$`¸†À5 KYds¢ {xlöOuŽ—‰à%À­åò¨ÉÛ)¿L À.eJNYÚÔYyß"?ÊäT¥Æ_\ðû³Êþ—æA¸&Pa”Ú¯£þø}r0'1ÃõçV_qoË@¹¦ìÇn~1p’ ¹µR^mðå6ˆ˜K—ÒJFÅ^÷M/j µ ïšic­_(”‚KH‚ÜVµbIm2üÙ†¿9"wñSLùÅîpÆÂ;ÊxYZóþl™õÑ¢ˆ]ð<‚¯˜Hk7öNüŸƒtJáÙ£A—‘Mò<:Æx똿œœ’‹I.ÛkÚ.Þæ„ Š7éG÷ÁP4Yà'×L;ØÄtÝã|(ãEÑ/HèÉŽåÈRð~¹-a Sƒ<û¤õÃçC6Xtu„kŠ1îÎkä2ÄE$ør+0@ã‘ÿÛ›gðíEÔªØ\‡ìB%¥J#y¼92Ú—åFD9ö«ÁFÇÈ3UJO°YO¬ÈB€v˜¡÷ìµõàâFÕa>è /Š Ë9ÅÊÊK Ò~b[KĤsê æý ñ—/ér¦ßŠ(žL?_`^F7Ê5>þdrŒqÿMnÔÆ9¾™ÅPÉV¸üž446¡b*IUÏä±*Ù"¬úéÖþÄ)æóyVVL‘. YÛ‹Ü,8‰ M¹$£”¦ ä=zÆ ¼"ΞŒòÇȼ5@OR¸ÁiëFmÕ„Äã ùùŒWÖ†`ξi É N(ã9¾œÁ`Ú^£Òkô„³'4o;5°²¢€ÅbÒö¤¼m—Ÿ}¬ž{Y×õx‡â:P@•æzõ)ò£éGïwCˆ¯Ô¯z’ÞF#Gîrùÿs „Žx§¥ðÌ–T\@Àaæã~2p²sèF%]ði›¬®0ݘŽÍÜ-åâ7¾O#H&Ñ¥ýhNÕæ² ˆæe"(©ò–ìÂosl‰Y7­ºBÕÕ/•õ¹i£Ì…·¿å`S;øˆIVŽhÎðë˜f)å%¹‰áºQŽ’¥ ¦€¤÷¥ÆY‹.zk¬ÞeÐDïþhëîø—¦jlçr‡àÀ̱ͯÝ—Ý’ ¼’$Ñ, ÔW-ðlr\…aZü¼%ê¨Û•àû ‘Ìs5]ÛøÝŸYrcèÉ©Þ^[:—-8¤š2>Ø/¥˜æåú£1,åò”À¿ «î³¬9vûÿx–€ñ‘–,¥k« Z°šä$rq ·³Ouü]B™kNN"Pëh!·GãéƒæéñaOå…¢ g—ùYâÆÐørRÚ²ùŸ_…fd .ÂÊëä8°šɦ<Ï¢¨ÓØM?X~©Í¤L`ä1=%RíC‚X½ 9Y0Ù¹ÉùQÏU ^@Î69Ä÷G²íWÅ5ä±@ºk£ÆGTI†ù(V(d 6c(W#LílbHÔõ½ìèYêB [ß ÔtoÇqv%—uÕº‘L<^"þÔÖy šÍg‚ÿ_Á ŠpÞX9 äÕŸUL8pk󬊯Œ;ˆBË_\vb¼Š‘b“Xçbx+›áºé±ÖÅJ£õ$»ÐÀ©¦);–gMy›XBä(±+g+½ëUšƒ1ôöÈ4WQ2}F BÕv¦PãVî ÏÎݵX¾ðzäÌø„àÓ°CðxÚrŽýsG¢¤‘xé5%((ø®Ü³üYDé½à2îbÙà@_ˆJ«•˜Ûï¸âþ]΂M$_(XMÏ÷jž‡H²|'Ñ‘š•.–ÇE#{ )xn-‚riܹc… "“¯À¥HÜšìq¾%Ì‚qñ¬¨a™d¡dÇÕŸáébŸÃ’ãÅhʰ©ó(c¿r?°ákÝ7Tí߬n£÷kP¨¬¸£Cv5+÷EfY&5€ ¯Ìh8$ÞŽÂ…Ùg㥮îέÎ2O¯Úº.fƒE5€ËŸeD&}ëHtù³žˆºé”߇_Û£Ìal˜Yã¥H¸+´0 <Ò/ÝœyFWI4yöX½ý»'å§Û°P–BŽiJfž·d2èmËœÏ9e_9cœ£Å•@1œˆu'ˆëÜy7S'ÔÊô²ê„m Öe‘k ãÓ1ܹ߳3$|@+! ûp1ã˜öAáuôU¦’FúÉž4ü×,uRùN˜Ÿ”c€GÍêúJvÚ`5òDÁ§ÐîP;õKT˜ˆÆ\¤E°83,ñû÷lNdŸh^Te´¢ôóÉ$ã™_%JüæìyˆÈ­©d§Â½ ñ§ÇóÉM·ã0ä/kº¥Kf`lp¸WSìC¾Ys"Ìeó¹ÔÞ*0V2u¸» v½ÄO2Büá(l‡ýÊBs›†WtRZÊ¿ED‹¼&¥×*‹E²ŒbH„ ±APÆ®>LSYÔ|™Ó2®+…V ÚÞL‹½@$ÑŸÞQ›y î@¸>9eÿõAáZÍ”‚;¿êHßaŠùMßXÔõ †/ØDнr÷ˆÃÌeX2)F˜ÑgtUJ¼Ž]yñáLí\Ã#æ ÝmpÙ¡­»˜Å¤È†Ž[#bÁ?ÒÏÐ8=Ý)>ç ãj<Å9€6OÃPj½ZÑ_o“$k»qé^ÁœÀIû¼Ú¦³ý ¦!€¹–2ŽbRÿ#tUØ·³]t£¸öÁ!—Ãälkˆi· «ê8ˆæÂhh…š¨XAÝïR×0%Ú2x9-ò®4ý${7X௫¥Ü‡Öúÿg$2}:¡.¦{‹´ ‰ Ûž_º4Š”í¥¸d(v%çaÙõ¬¸a9Þà?€J¨EŽЛÁ%ÀúEBc݈e2,v;W/e‚É8õ>*Ñ--3+ÝzÓ>+õ@IâýÎÞ@Ê^-U‹ÞœÃy¹à¿¦¶À€OV·´ª|¨O“Zo„XM܃7tîùH&û‡þÆjo³fAþÝÜ¿X¹]— åÄf}Ôv@¡îʼ•›xôªbÓW·1)sÿ쪔쪠GÆE[\PQç]Ò¦WÅMT" áÍß_ !0Þ ~ Ï!jQƒÆ…„ £4I¹û,u¿KP’óàÄ¡ø~‚ÚLÁNc;S󔶪Kl,»ÉLʇÏâ˜z¨7M‹wáB$`&-\¸ÄÀ„F5¥Â<ëCÒÄ"$Ùį¯ÿ)ì@>Iœ§*ôÁöéË}ñ];À)|÷2lµ¢y/oM¢BžÙU?¶<#‡ë¨3û¼—ö<*Êþîˆgøßʱ£?Wt&þ1€(Út®c!ú][Ÿ!‘3þÛ×G,xaðl7<φë3p®äÌÿô o7Ö¤ë‰5 Ï!E 3ðH\2諱.’TI´òQ¦ºzNÎ)½oÄÀß7ìù+û þhÒT ²Wа!ÓâÆ¸‘œ‹aòâ“•øîcÿ¹‡þšÓŸ´°±R¨ÞµÂ™Ü­á)h±‡—ýôºå~i…INÉ܃£¹ï•£ôV®ëF±&Íø»%¿µi°ÒÿO‰ÆÒ­Û .VVkYª¯]áÐŸØ HønÈ-y©7f '{èõG3òCS)kH0¨ _E9u©[ãzsÆ#Ö´65!¿Wk¬†m‹ðÞ4Iì.wÉ5ýáõœlÊ™7n~´~2¸S÷Ã@·róÍÃâ €æ;Kµ|*–€n*$3†jn¦¾»g>yIuºØþÚ,4ÖÎl¿ ¨?H 5eŸ1%ÔŸ×åu0'»ëŠ‹y°He¥ Õáûec–2•[,¶0ÑâkVØ~‹~Pýë r¿þ¼Ãμ+/oA€2j*DhS?×K“Ñ„çƒ,] ¥ýÊŽeä9èÃï×±‹l¯m­÷šÂ)Zh4ã3‰|y.vÝQƲ•*ùb!±˜£Yù>ú9Í>ò öÔ¯—–§/ZÊ[Ÿ²ƒ££ «´9ÊúâÊô Lžbi§ãõÝ,<^÷Ý_c,פäëBÐÖƒ<8]ËÆÈvàÇß\ÛUõë•@­ë·¸¯;•³•}[&׺a–JuóíÁV±‚Êyç©ünÍ”Lt¨/ºÃ±fÒuÆKHø¢7à FJÇÑÕ¨à'tzU+s@ؘßA·©#˜&#¤ŸU:¹0¾Ê1CoV¬…|FR3VËFîÂ)5!QY8mñhëé¼^¯TâǼ¨i:Ýâ` ÛÛO_ ÖtDÞˆrÞèÚÂÃvÄ:Í23,,R¯R1Ýmÿ¦ýøt¾<8¯§ ù^þ^TfâýÌÌ4¬Ö¤ßjj`Úê[шIzüø¶fVš+4”¼‘:F)‚ˆ¬»—”®P–ƒ¿,Uí¾mH¦ž*óŒ¼Rê Æº§R\G dg»äêì/ʰ“Z¨ó4Uòu‚Q’¢%žè:£«#4KŽ‹ £M-˜¬>GýiDaƆжšazAtÆP`§×íþ­(\·û57~ÿê›8ÀEkûIŸñ“b…fÏ…)óåk†5Ì2꤭®ó¨hsCñØZšå(8ÚÀe,$:X†F!4ÿT>$ÄHã×ч–þ`1,T] ü…WRÅ‚…GÅý) äôFžE[-¢kCª¦ûPqÖ£EŒGI½Q ð☠Wª9*Aª¾}D’èGýýÎ)©N-*$¨èìe’ÒUæ27jVD9—344¥½„ “Z}Æý'½ý’RS`h,§Œ.b Íøh'ðÁ?ž¹$%ÌÜ€»¥ŒjŠc|øâ£¡)‹l$LJ®ù{!oµkd~h7»HÙ‘N Ê¹‹2Qñ3Œ2HG9ò[à`†jT…ò¿nþI†¾ÓI¸ñi6@7°@t’bŒakªaž„eheÔ6¢°ÍýͬX;šn¸<ØE“éšUQŒxÔ æu¡y$ú`ÂL´üvùYÆÓha=+qü|ÂNé%×À2ÑfHèÏu…óBG£à߹׋7 EBñwãåî97yõü8m3h¶|E&ŒœÕå ¦UR2h¬dSøX¯è߬8µ÷±D6­„„ñ]Eâã¯vñiïÆÞ l U ×îi>J‚¤|È‹‡cµà¯_ð 2å†pe–ÿE&¶‡¬Hc=å^4H«Ý°ªu2¸-â\@Û,ä3(XCÒìñDÁhÛte¤Ž±_ñÞlÛóÆ1¿LTñ,0å«Å°™®€±] F}îe ­Öñ³Í\ð¼b",¯¹H‘KÈr+×Õ±QŸrH.²ç)Óìè´w˜Ï41+]Å:xsfÖ‘ö¯6G›óhæp‡°<ˆÌ´»dü ŽÛn!ùÉÐGûÈérW¸Þ]s,àI÷Wjyk}>»M›PÂÖÒ”ÄAJ»?…ß'ã2"~¹åûº·: bBÀdìžüVOýo­ lnsâÜbpÐU½CHBE‡c}è–œ‘?ÉŸ:ß`}SÃ2ÌíÚè;/Â:˜™óð ÑeÈô/îàÁñËÇó<ƒ‡y{O£²Rè=é¿z´ ¦8ËCóS17&o•I‚Áq»ôÿkîcñì0@ ÎÀ8u0D'uCaªrÁd?ëÒ <3Ä–‡&ÀÝ[5lŸ_ZLÄô®_USGQï&?DÜé–¬õ5Þ±U üÕ¦d¬f„ò‰@$“;Ì{Gøl@Š–tŠ—õ‹éel•¿º>ºyª_ôwPEQ,ú¶š/X€§àÂ÷¢'’ˆ¬gNåÞÙÕø±ÒR`{“¨åðΡî/Û2—Z´¶Ã÷4ûœÔ ~Ó™eÌf²: rFï±ý=쬞³»!ØÛ@T<Ò[í¥4ë[ѼloaŒ!0Ïë&xÁá(cMÅwg—UŠƒúµ€¼,ÿäȆì­!šÒ)%/w³™5OÀ†pTM0ú€íöhEJ¼8ÁËÉRrΩ‡^»ð=†ÑdæÄôÓ›#éçu–êÉp 5+¹È0Ë $÷`LÎF>»-Pê`PÔ¾jußáÂzGCÊýȈŸ("qÎ(J7ãu“ÎÇRÈk•?‰AƒlìÉŒLè“gŒM Bj‹NØX1†1aJ³Ð=6îj²;ŒêÝäÎ܈ɮì‰!©ˆø…x21¿³Ån±HþìW)òÅfO·Yk Åø“‰µ+½vØuHTzç”°Þq‘|–ñ´çŽßRwI¯(3Kë[TXrpq#.#ê v yuèç½ëMjÏ“pçT2ÂøŠšÄ.*® ¨óÁ>UAÚ½+½Õ±…~I^u`}žúêCè˨¤ênÞU\È/µ•ìýÔ•Iü¯»A¾¡Ùä¹d!Göe¡‘Ž¥¦F>×"Õo$;™óñMÚŸ ˆýЏlfRHŒt!_@j5/. 7:—øc.iÁaòðZ IÄÏöÃî_Ý ø#7ó)»Š¬Sȼò¿‚q·AßWÜw€%=µ‡C{ã—ªQHýäpñ¥§ÏxãíÅcØçcËŠÍà9 E^èðž´¾!¡c€×ÓEõk ÍlÊö^7Þ­?¥öýküWŒ ²”OäŒÈQ|$ÉýaAéÕe×ç?'Õà`vh#'US'ôáçÒÿdz>û¬bW%GÏOäõ•)ö/äðbNó ßJ¼pH  ½¡ˆ(0dzáÒm!’AôÌ]Ëf2[²0-¤g¯Ï!,òëËÎZ^t “økHµèèIÿ* $ø²ÈŸÅcÓqaƒ:–Žú,@ÇörðÒD×°‡ÏöŸqšºÖGvÛ¢õ––Øãè!Ðü7%Ú5ßÍ”¹†­ÖfžÊS˜‡ã«A9ôÿc×—Ì¢™*;H^¿(³í„é·…ÙÕžÙ{(þ?ªïÂøXø’ö5Î¥,êÞ/IšàkìYô¶Õ[CqØì»[üPÝc[¤=fëY[>€Ãq€¯ÀrÇÔ?Ê⣲BHdIíá!­?„"ŽI_g²)R«µ©¢ã…ÃõæA]ò”‰¸Ü'Ó;{¢ys›ôÛ¸?…7éÁ×O$þH”μUl(6>¡y‡ÈÇàÁ^=ˆvôO…Ábm¼¸Ÿ”#ÁL9Tl˜ ¼)Ÿ§æp‚Pþ…õD/¶ÔMºˆ^Î?Tª$¬b¹V£Ž7Z@+kkÁ²ô‘§û²÷øÉå5F‚bjx¶èøí–Qf€£Y c§Hì]x tÀ ñÏ|æYŠÿ?½¨rO‡Óêý “2—£—M ;ݲÉyú >°Ï_7 ý…¤ã­hº4dW/{†¢ØR©;lºí´Ìø&†EÎÊ(³ñRÍk&Y_Ǫ†Å©‡[8Sy–ü¡ÚAàØÜ¤Äý“RNǶ9Ä‚EªN1•ûw¹JŒ«¤äÛ"v£ñÐ!U`u[ –²Á{Ê0fÑ=;_ño"?@ÐÓ‚ýÄoOz2Ä3'CÝÄYaKÚ5jJI6Ç=ϰÉ,D«£Ð Tý.d•±SÌžh9WÄ5³3ÃRp’ì=" 9aËžFe,Øiþkº.~~ DC„²–bßó l5Ööçý„âÜæ­!¯ÄÛ)½DLçŒfŒ[J$l‡a> ¾FcÆŒ¢sÅŽë\ÞЄŸ Ij¬¿VP<öüb<1_)™ßòª%h–8€b¢q&Œ&hfq0aîæn•C2) ò ~u{÷q“0Rd¥Û¥cò¶>Ø "—çâý ¼¦ƒJ<öâššÁÄÂçž°À^Úy¯|$fÕCè* AÕÖØd6¾r?hçâ‘;wÞéÈÞT,ñ{׉ÜÕÑuñ3ñh °Ì$¯í»ÂýN2-'`´Ù±ï»Øø O?Ûz.D$Ê!4Æ… ¢"—TMzÍolêrÞû¨Íï¨ÒbÜßr[»£ÿ¯êf²‘çG”LÕå9d6·wù ‰¨f^ãgõ U*L©Ö‚h‹‚]eÃÒ7ÕMÈ^¨)Zí ÄjËô™rE¾ŠLÚ Cœ ?ëúî§jŽnž(qjÚØZ#ª«6ßÙõÿ©ñ½AÈÖ~@õ¨´—E`7=ÃnGôÄqI|Žô Øi%y]„ݳs¡edK°ûD+sG÷µï¢<˜ƒ—@1zc«ý@ÁpëEPL+•²;’ÁBCKµ4€V%ìŸûìF2©è º®ö•y XÀ{ÞìhÔ¢¯àùlL2n—ÚÐCÿèÀÚûç„dc-}ÝÈÄ4qQ%ãzw­ÅÀˆ¥‚p¬aiÅþÝžÆ-½Fÿ @úyÑê‘—ÞW+@s€)2õK9‚‚sgÉ-¸ €ôg®²k&)Ø}Jê!¤ª¢þV—¨RÇÔCP{*eÍÝ´ÍölѶU˜¡9Æ)2sž)¼"._¦\1Â|Ê\¥–Jñ—#~ÜÖ„²iK.#¦Ï`Ï‘¬Z/æXÕIA {>¯y/8;[SŸÔUâ÷«XGkà~»¹§uf÷ÃW¾ ô§<¾Áåw‘ÀxóX³Ù ÏbñeX£+TúX¹;ˆôSÔ—ãa +Hp4QdnÙ4³ïw=V&NÛŽ½m,+>'h3.zðb=j’iO^_ºõ¿Ì8¸iÃc×Nâ~éëXKl¾%·ÿ¼aìizïSÅwƒ .g£Û¹ÆÄn¡Œ¿=‡1pWzÎÆ®Üõ` ±˜ôéJŽñfµ™çö‚¦TF„#Ž–¶ûÃNü™92”}³-T8ÅÕë–ÇuwÊÚ]6¿ý/FM?ÈØ) ÓŒü9ÀBž ¹•؆~0¼5 ¿$Päˆ*¢¿å°Ž¡ðdÅWcnuÕUNoÿÛcÈNG fòr²¬P¯Xî)á?ˆ[²h…+—33k?Ç=™ù¦;3 í…½nhéB! ݳ µ jÎLlW+²w)0Ž|YçGçÝŽóŸ|L^Ѭã­I:-î4­MYœ¼3ÏpÔ´!yÝ §QmµáÓ[S?÷q¥ÃW)nysërÒ êa³MìÔ!{ÊcÐfßKôºÑ`}ɵ°‰Ñ&ÆBú»Ÿ24üã“<ì"Ò°üÑÍÔƒwü¢p2˜†Y­£e„ÛÆq±Õ#þ¹öè š=ËåàLóIR|ˆÜ+(Xò7HNùRj.QV1¢<Þ%2«‚'y‘Žþj›ya#uÎæ BI=x~I èÕqŠ=ùnB_!I]Qð £õí ½ŒHH¾ÓÙí·ºuFòü¹ÖÜÉÞóý.rˆ:‡ ËSÿ¤%”#‹Zù8j¼o=…ÔBcK°¢À E¥;Õ¡ÊNfrÍåy@Ÿ±ô6›$¡ÂûïtnáòQŽ5‘œÞa…{¹ãšJ‘VJVJð¿ÅÁ"Ncã!¶‚êRðÙ®BæåüTÕ\Íz¨ö›QÏĈF,<˜ªX”Ń;Ø¢û>CÙèßH¿€íꟳƒê@TºãUo•ÛýXD¤À2mÍ-Ï·žnÊÀ ¦C E¸%†í[Ë0øWÈSFØâV=Fö…tõˆ>»Ï–tÂébý²ö>‚fO‡J'ÉqœM‘çCàã‹üŒõˆg×Z;Tˆ)i¸Tk•>W?å@ÀY>Þ©B^V|¯8aîË:Ë|MTg8ÁÈÛ„¦ò]̉i—y^DI…)†à. e¤{êT´N¯q>X|1<²¨ô­$Èÿõ7±O£Ÿ#Üùd¼pþ‡"—ùUMT«Bê ™0įgòldŠ}D•ÈŽ³…ù·`"èÄÌ!ªî?¥­é°×É´§ÂF…\>d‹N¥½Æª QöÜ”©ë@kUál2ƒçÏ;¼BgMÉÇ€F_¤‡o8Ÿ½àzŒÍ"6Òé^ÓV9kŽf8Ÿk{F°¸Ñ6¸^ÈQêp).üQ”ô‹ÞÇÆ åó®ÅN¹ys£c{|\¾$B„ºù< —è)§Ó-ļUsß Ž›Y DÁÍÀVŒ‡@Ðjýù,,ÔŒ×>irddf=ûÃ(-k¹¹@Ò9ÌÔ‹5ÌÄw2a ¢fus:R¬l~`©žt»hŸÕUQîERâÖðõÂyûæÓ´ÒH}DV3ýCðAëJÈIØãdKFÇ…QÓu5ò¡ š7rº$°ê9™#ˆù;&WÈ—7Ã{a7ªÄ A0×êÁd¾ÂèØV„2L‡ƒˆ½0T_eÆ$â—Éõdoæ7–~bs5ß–v-xÄÓ £¦u(q§@ÂÐŽf14Ðή$tj¤èa‘‡†À•yþò4ýæõô“þp>; {/`yõVÀë‹'t =Pˆ)éfJ^wƒŒLWq’)u|º\kÿç½±WÞR:ýW+†„Æv.·«—"é‰6¹‰/CÄnPK°£šE¤§~^ß…º ½z+úÜUÓ{D$3N÷Zã@Iͣ݋GÚÄ]Àܦã*;]m›Æç©OõúŠW]›¾.=ûj’ô‘õõêRe †•9 «ˆâÅ$ »T$‚°#˜Éë¹!)H—ö5Æ(âz±öS#Á¶×jbOç‘¿ÝOúÒÉVÍ+•Ê@Á>~ôlM龕¦¬DI¯€:…Ʀš8yªu?~¦§- ÔÍÑh¤REr*o̘ueF_™G®›_C›C.šyæðC_°·Î9¢ × €ÖÈþ£ËŽZH Û¦µ(.úQm”ÉÖA9n‚žÝÁ!v6›‚›ÅisÍ–³ÍOjíW‰9M5º{ÀÇí^+î)L÷Å8J2Õôös0¦DCÙ\»r;×me~Œ…fËJÆì•E¯=ÊRöì“‚p¿cyG/ÏgJ`“µ¼ËËŽþD («ÅâzÛV’4ëóß•*5jˆy¦ªÛçlóÈZße޹)^.di3x•ܨS'NŠRÇ7^’5¿v/³ÿô}l(Á¨›ûüw6•ꮓ4Ås-ZSÙýÛÆX ñPDµŒ©Ìu¢ïò:ÿyó?@8Þ9zTÈNº³PBãÓÜ’[$><›­ã¾(ýE¯ð\Ûž¬Èfå$+ß–óL—Ò®d(ñŒ®z;ý48è•; ‹~)ͬôa_á/¡¨ˆ`…GØèacxЄˆ‚HC 5…²)œC‘@-ôH¤5ma»?;ßæÜÕ[‡‹NJèÌ~*>°(Kåm>û zs´Û„ÂjMÄsæ°-²ÛŸ_¸U.Å£üÑê?ä|Ñ=^®êðd`ªô)ˆ"šØ$E°á§?D†n´›ŠI]Ån)¨O8_ýtæZ#”åèeÒ…ãBi²+€¬ÚèhxÞ9i/vŽÿÝj¬† ÐéNˆK´’³i·§½Ç4¿ÄåkAÒªÜ(À“¦õÉùWúì8rv¯ÌøkçŸs.b/?2°Ë9=•`"‚¼Å\œd bk$nK.Éðг"ê¸@¢û^~|Ö뀈¢@p§O/C'/QE%tx¡“Š(µÏpœ©{ xpU=‘—?°VÞõ_10 u?#y~öŒæ/_AùÔ{Ê¢ý§h ºÌí%vÂ+Üp²-”©]¯¡»à„šÀ˜º‚¤øSÛ½ÇÖ”ö3d@$­yåb×5N  }§*ÃÇpĪXøï×ß¡´Ž]Ù–Í»ª>6ü½KGJi÷-ÆrŠ¢¹§AزÓ8 " 줹á\!UÆópó@dí¤Õ¯9´b£>:`ò·ÜLº0´a* ù}G–XQyCè­VÒ‚bk4ñjµ<Ê•ü!Í¿Nö`“"|ÂÐ…õÎÿë@¾¢4ðñ«M#‹ ÌGjÊ Ì‰V+#lÈ&*N.ÓE” ¼ó’WœÎZà²D\‡a?À›t*_'›ÉC=IËOL7F÷mYÂ~ø.~X;9Àe+kÿûq·Í¿ùãà\ÈÅ('²:A-«è£ac ±V»\¢6éA4 & >C‡˜hFÓ o{ýz2aÓ#¾Œõ\)ó-d!ÔjVè✗n^LjQVqË“ͿӔ›A¼(š?äc3wÊÖË@ žì°ì—[7RÕ$.ñAIËø,O[GÞN’`$ws:ݲ¡z®=ˆgÄͯdp\Yà±Þ-Í·Ÿ¥L`ckXÔ·ÿß3 ›¦i†œÌ„a+B€yzZjîƒ^A“@yf{æ±ün§5ß8;3Z¥‡ ` ë×HK¾x‰ª7H"„è@¥·¯LÔQê0$ˇ»6¸°öÚˆÂåXÒïw,ŸÌî\8çh»¶ÓiI1:û;EŽ-©ƒëN\Ѱ|ìÉg¿b~hü5ö”‚ õ]KÖsxÃ]ŽúqKæ,sÑí N„¹¶SZ»Ú/]ET¤ ØY;?…•?ˆH¬íKoÝ'åÏŽ5uÄ 9·ßÄ ¸¶ÛûUˆ?LÃþÏ}{¹¾HØšžnýß¨Ó±àƒ Ç …¦’A˜MR4Á‹ö왽Ø<»N‘Ÿ-8c¡,Ê’g^M&%ÑXåÎÄVç¦Pj‰Å€ŠüÞºÕàØô`%òž€ì8_Hƒ¢šèº„M›ãæ_Üú­¸Ô‘¹a4åe#1Ö9ƒKkÞ%—77¯¶aØ_\mµ¿k¥ûÝu=´Ã|WçpŽÐ|iÀ*ì)ŽLôbšéÏB{æd³>Hý{Û–ä1u>¤¥ÈÊì²Ì¸çØwËÊ“¦ñvdçÑ<Éæé*™©@±þ]h/=ôÓÞƒƒ¹ì2öí=)"úÈjúS€E[‰ÇwÝÉî(Cn„@]kÙšÆ.7&½Õº¬†Ç™‘I¶gQ½¾A{2#°ÀIÕ»ñ Y( x Oz“CÿK}·—½^Æýá‡Ú lŽv*¾ã´â‰Àª^ÈzÎ$~³´âÕZñå©*W”òE}š…E{{Žœ`™/x޾Ö"WPÒLfw¡Lv¾¹>'ºª»]ñÿäà+¾RTþ0–OŠ¥ÇÐÒ‘Q™P£ÊŽ]z£÷È\³=¡Yñ_©[ ÎjRþ«(2B¹Œ™ü™7+ô;Óœ7®Ebg+¥Ü)úº'£ ÊD[ƒeàm$ïÕ{Ðù«—LýèM5Vð åû¨ ¤9ëõ<$•Ææn-ž”ê+.?âp)F-½XUañ še<ÔN€ã|=:+#ôK²TûôW>G¸]Ó\]ÍÑÎÝFØÜš£@ïémœºFù…þO—~e{ 㯰j˜ó¢è¢$U,,1²‘ C<œTúlö×úL“˜84©¿MʦӋy‹Fx@)‰‘,í.•¬Bz¿aÌkU¨¢ÃìÄážËÑ·!NõÑï·¶gdùœGÖfÏFXNbW`HÀ…÷·‹É7œLn£,­`õ¥Í*³ãxŽ=ĸÖIIS](ú•#‡Âœg‰ ¤ þª¥‡OCwfªÓlMŠÔLBUPØ=€ææžRªþ›ˆMˆ™7RÁåžB|’ê>ZÑŒ†ì4[&½ˆ2x£_àTž¦±ÏÍkÕ8é±gZ+ËKüEÀ2¸·=ë½g‘Ð%ž ”>ûX®Á‹‘È”ðÎë für£ëqæ]&ÛŒ²s(hU™LuœNÅuV%ƒ†D«%Áù²&öf3å'ªËö>x1媚èêGheTcƒxŒI1l1|zÅ»WõššGå»¶¿ïg ¨£õ)ä)X0.ûì¨k³™zµ³n‹—tŽa”ª"@ßžÇR‚ñ½:N`ð¼j»M–¶Ï“24xìèî¡%lðO-õ>ú@ë8ߥ ¿°JBÑhC-ƒ!׿ïz©Ûp.„+ÁrÅ+ú¼Eº”°ÐAîÆñ‘vÖ:ŒÕ¢)3~•9Š`}¹Ú²“eo½z"fg&]B¿Ši¸ÅܪV'Ë(wÄß‚~¢"îÏ»vä%ëyaŒJ‡¤WÅ©éI-´„=T»yšŒ¯D))9¾‡µ aÿÉ76“° û3éIKâ“YÇLLBœY[¼ dðAWOÏP¡uŸ‚Êÿý›' ›l£æ ‰s‚ ý²ÛùKOöí1vúVp&’mfï%ªkhÚÒ£l–Z=]„ ¤´#µ¦è»ÌN˜aãÛÑÚ÷/öÏáea‰XoEUL B3ʸÜÕ:_faOЇ¥ß1`çþ𫦹¥pÝÌf„ƒtæ3¬…¬»úí¿2:Ø¢ßÈ‚e«p‘‘äü„nHå ®¾tY$8E`Ø¡$¹(þíÍìѪC¿âSZÜ4k¸Õ <P‡3Û×ÿi0Š1"oqþÏÏS]p–^Îâ1†—Y\TµWïz8èJÅp·v aM6/ÀBÑRj_9âcéZð­u/E~‰ßd9zÀ~LaFˆ± e ¯ý¹þŠÜ1UC×&AtÕîóZçLyæåNè:x÷ÂSù«@ªa+_û#ÄÞp nO€,}Ú"­. 0¯­htëN/¬r–¤é;H¼nƫȢ:Iûñ-c*>/:ÑØ¦ ¨`÷1&ØÄN?ÀHÎaIwäªelùEwôNPý¸¹­ÿîåK°ýoöaŽê”š)»¸uÇ3%Ÿš1SÙŽ½m@I*jc(@ãT¢ÈX­T,LZ) :ßÀoÊÔÔO—ÕzL“ªg™Œ4öVzm³øoáÆ+édwã©rÈÑnbñ1·H’@•‘øýÊü AõZÚúNTqy5ÉÑÒI*¸Á-l åÊÀ:«:yìxB ÷Ü×+ÇrHð»èÂ}y(ÊYf.Uuñ»dÈÌë#ËYÎI/al£Bj[-Lå1IÖ”Y´ƒš OQVQ‹Å0°³ËaëTc [BüÒ9óP%(ØU_Ú‡Ù-Ò’wÙ@8~]dó9aö¨5·«5QèEÿbµ´ |ÅÔ¨ã–)Ââò»^^oÅZ–ËõÀº†ª…{™íšh,9V·•Õ&—ïÛr+WV+<¢eë=ñ\Þñ¶Ø2Á%Ï4ò½½±ø.ˆÈÈZÓõy…¾ØW ü'Jê¾=×·cÒó7>éÜZ´.ñ>q~ÝœAGíÉ*<)ŽŸš‰2Ë &½3©â%¨U)Œh>’ý¶zyZ¿ÒÆ.lÝ×6ò*£(uôC§(Â1†›&.¾È]KõôL¿¤¶N¬¥ö!P ÈñúÈ/ækTÙx $5ÎcñÁ·BFK—On0’¬~ZøUbבlD†|?íƒ_ˆtSÀóöÒÍv4¾Þ®hoûÔ­ñü$µ•_%ÕËòÖPH5H%K·À0ÂÓÖ¬îÄo Nƒ4K”å¡LHNƒHñ°Ïó˜[ô\§³#(ˆ§ôº HÚoC™¼‰½pÌtr§*=nü=v÷ÀÈíÔ†¾MM NéjâОÒ¾À£L/2zR+ÜeÚxÍÙðnõ$²"þ4|"òʰ½ãèaã‚#\ùcG%g'Ť-O`°4O¬» XßKô_Ml‡ª5Dˆã·´¼ºî]|¨’AXë§×åÚ¯ð­žl¾”P©Z}vUÁUFúÅÐsº9æ;7Öó]èD(† Ø›µ<,ÇI’‚êÒ»•ñE\ë+ñ£Ø#Á#FÌ|YÙo1Ï\V½Ç«Œ†?dæøwvÒ¶°*¶¾†ÄFòÇËÐÅŽ5nb׊ª]·xÖ"bŽR ’*þÄþâÀõ¬3op+V`ßV#qŽù4c²M£2ɶÌŽ¤¼U"‡IîêÄ_¬ö¹¼ÀSÎy[нéH,ÄKP¢ê¾1‡¢½N%ÉïpÚn T7Èp¿š,…Íêù²vÚÍ!ƒhƒÄO}ùô×S,úЮ@eG@’ gÉ¿N ¸}hMd¼åFÏò“€ÁÕp( Á¤ ÿ¨:¹mB±YÿöïU½8{Ø &:˜ò3±ÐT@k ±÷Üe¸ó‡ <ë©o} ï8ååX p{zÀ eÙY= ž>)»¼N­P`;­ÿćg( óéOŹL^+uQö4šñÄ.[³“"͘¥|<<`iàižR¦Ö£‚ì ,5N"É)[n¦@'6Zƒ,õ÷“éâváNÈ,ÉÝÄÙCï)rÅp¾RQ„Â5¬QnÝàOmIÿ–ÝÇ\ÞãúüðQ^PôHaî?ê³%HÀ†#NÉÎö„ã<:íMѬ<ú{{ ÐЭg%žÉ@ˆý‡ì›]d¼LY!“ÿ Y/>rï-„­Šh3Z„bë{%“tM…Õènp¿?ÏÚ|­ÍYÑí) 9Šüüýo§‰C²ñXkõƺ±¢9'NH²=BÜ1#8iùZr9ìX£ŽÊPUÒúvÀÓ3ú[:å÷Én…{῱ǥµ²eÚ }Ù¹¯RíWçÎdÕ«‡³0~'#)gƆ_O…œ•ˆÂ›äíkm+SeANh'è,¨>ÒÞöí ø•ºm¤ >%ùêbº‚CÌžžÝ†×  . &Ú§–¢Wá]† Zþ–@àN’É]¼ˆ2ÜÈ—†{|€Èùô“2Âu® —ýÉ]|t(g±>MÓË,§-ÏåÁs9Íwİ“‘J­DHO·øá â|oæ¢uø…H¼9ÀçZ£Ž~*¤½¬Á›ÇFÆDö¶mw½Z´í¾ð¤û蕦ʙj r®,œ°_ !@­è0ü˜rÀIá^ƒwŽOÛ†°1+Ü\|6b’¼T“Z_ÙøÊq-tÁôâ©cƒq9·•c¥÷ PÊ×gSpá$‚ñ%¸«a˜ “u;ç§Më_ ”)ƼÐ!•Anæ Ráý®Wë­ó•@jÒžõ¿óC\DhŸÏÊûú%É1¦¦©ÚÚdß%½Ñç Óypøˆ2A§7\£*»ã×ûÓuŽÍ²/Ö\1³%Tr8³üˆ{¨ñe ­ìƒž€øêÛ\8l—(EØàv¯ßEÒ°¨ÿª?}Üz%.®ÏŸ^vgrW*еr£è`ð•δ䱃(~™Wô >wEjF/•^ò5R¯¿Þz‡pÅ锳ˆbçÞAÌû)ÃMxbáJÙ W!òþJ¿XÁ«ÁÐP¥‘]Œ1ÇýÓalÌ™õÙHb„çÃ(1ÝTäI§v­“—Î.¡x3Ê—ÇžÝî¦Í=z™@ ÔV`sW†ü ’ß00{)B®ÖÆk|ÛcPfÍ-2I"’GñŠ{/Æí1QŒÓ˜I`-ÌáïŚ ¨ŠßT$?ú§…ÿ?– òGòNìÈ%áÞªïÊ”LW–¼çŽ(®+b`Ý ÍôúÁ%Ðêóš§wælo¸II„ûPR+€+f?¤ÞÁó4)o%š R¨¿ÛL®Ù³0)’À äu6’ÍÿáfÕ†ˆDºñxF_2“ -²¦‰Ys¸3ðÉ‹àþu9’^BÈO]Ùå§ÐGæP_µ”šBîI Ál—¢©ZÎ Bó‡u::¹mDæì…bGúº‚?Œ¯­‚î4˜ ißy†p`öô'HÛÙÓή«pœÒÉÕ-,ñw+{&·´¦¬JGà©Òˆ¯b¯ìÔš¸›µù¤4÷Ægÿ…bûÙ…&v‹%^߯‹\+Üê²×S”H!M8Ðxÿ9&´‡ yø´­};£í4üŘñi%}}þˆì±%š2#fÕ!Kgš òÙÝÈyîr&8ª;ž•Ö£#bë„H;šöÛ!S»Á7z·º+ZKï5ýä(_Ê‚åýÆΘqÅŽ=Xæè… &Z¦qÑôn˜œ“ þã—(~9I.àéYŽß0ÔñühÃëÌŒ]a&…ùID{ƒr~yb)׉«ã”>};j5ϺEK7“Ï‘Óær×{†ªgWêr•xfÜü`´8n@¼úHv?½Šê3rÖ¾B1ãÂ|7íÍ>Þv9£‹?­I¶(¶&ÿƒTš[k(@44nÕѨU•dÑêLz“‹ÂþÛ³ÚÝ! £·°¾*‹Áý`Í;ÜX&!-G$Ûf{’b£;¶µNÖi²FX™ÝœÙr&ºxõ·øÍàJ²Õ†„b¿Òn£¿ú¼F±·¼½(ï…3 d¾ÊpQüžfÝÁ¤ÍHª…C‡ù8VDCd0˜ùî YI Ûð~݇hE;*ÅÖ+J_éóªÎl1Ô&²õÃqº{…ì°’¨ãTÌ^ôz¢Ǽoþ€Dõkv˜˜ÂíÍT+¶™8v±ßùz7ÓÍHeÿ‰‡7 Qk¿ðÍÜÍeù¼õô;t»Õ‚J¦ð²Ÿ‡³©×BýÿP¬øëJ^Biœø ÖùÈ$k€R—ûö!Šöy×5ÀA–Î.½«FƸ/´ XH ë\÷ñ úF[^¤cNâ\õê!À†¾üfíÿ I飒ٗt4» 0—j÷ïÑj0öþ&4^¨ywdþZ¢X8“Žc‹zÌ]˜6wÂÉš6­È ¨ÒiŽ)#SÑ!™•X×ZV]¥Æ±æE<²Û†k­Ï%Z§þ¬Ÿé¡ÍW¾šTñ·8ͼ I‹gAøÃXêhA_lÚÓAMºqØ_±SCcº'[r)eS.ç=®1H“*s޽Z(ùø») þÕ½¦vúñßy,÷ßBd¯3g_ɱÀ¹ §€nH†gÊ¢ß÷’ÁY ÊuiÄNã–×A Ääz´·ï/ÑL:`œ-B×[4åY(YFº³vB bþ›ËZƒ¾!ÚãîQÌ\w@(4˜7ýæSè-Ø2X ßúbŽÖ­›‘ë 6(ZúÖˆ6 ͪðüPÚœ[¯æÒŽ„X§¡—uºåíA…9ò'yû¹uGY80ëËm(QrskóSOýÇCý«ÃãLJå™ãÿÄz™ŸD!qLë’%±½ój¸Ó;V¤¼ZõîwÒ /ÉIÕ“ëT:Â_|!™ŽÝºùä7sÑAö@dh.R’Ýï•§m ¡1âFÎ…3«O ¿ëøÑF\ú,ôšÔÌ×áæ„« Û"OüúR¢ƒïXK0ä+Sü5Mã/ÙÄN¸ ÿ˱M¼nSݼÆ(þÞPa!AÏ&ú£[‘x¥*²×X“,;¡®¬®êÜ?½APÊ–·CÏI3‹@§Ê»0)Äíåƒ8m“”J·´ÿ€žƒpùÍÁ­¾áÀ¸\Ñ ¢“BÚ‰a›'LÒ"j(©Ê1Å÷† üó’ÂâD*¦Ýi ̳«k¤Æ$›0: .(é`ÜÓ#!Ó3À"À»“|”¸Ô!Û°gÌ&ÛY[ r·a©”ýG³Ï¨Ô60²"¹ãrô[@w4RÄe_ŽÏ!ñßy±MK6ûEs¦˜@°-¬Ô8%Öj+Á2#ÂzÉ×qœªâGÆéÚ÷ÓätEdF@óÅ9YÏ¡škâÜÜÇ•Xf[ׯ\ê’i2P§Y° H…ÀÊ—ìÚ 6½/Ùôª‘úxwim§š’Ù­5‰îަI pEÊS¢ÌŽ5™výä  Ðre·wQŒ¡ˆ'o_ÿ¼ J–P™˜†bÁš¡KK„yÅ 9óCHq1˵Kpß Õf"NÆ’y°b®šH÷'[)ü d.; Ü¡‹#:ÈÑÖz¯qœà柌-^:F"TÈàŠèñTç©nH‚ê}Q@0êO«¯If˜4ÕÏà >¨NO,@C!T÷9ÅàýŽ7p4þ)âçŸ1¶Ü*ÚöØk‚ÃlG~NE6´öîôä Îs`|Œ­AámÔ¯ÉM¿ƒPø~ÿ`%/WÉv$]Ðßà.s$`’ó/Kº ¾õ/VztÖ“RfwJöB5ÉõE0½nyOÿ~wSqòò.꽞y[ˆ» Ñ™ù!Y¿™Ã¾ðÉ$´~¢{pd+95:Wÿ•Ú`€‰Y{‰€AÞ©Y{Ÿ0&N) õå}‰hm/„MOª÷ÁãqGS¦ô>^Ùl©ÖY‰6ß¡5«îÉž•¡Åð1˜z…§°|$Ÿ«°}áh/\TÄ[³4L¬Î‡­,òÎÚŽ`³áZcû®½±ú ÚFùÒ#óema§=â²U»ÇN]‡þí¿l¦<^ ž{ÙDõ>W×Aš?»9ößìFÓšä⮽±Ußüpnð:ÏY»Æâf4ÉdÃÌ£}<àÐøSÍìIû.uP'Ï´ÄU(V•™›lF(ôsôj~beSBBcA…y"œ:ÉHŸÐ/Ð-.#^^½Ë“´¶wB zÙs±Q˜±Ò´ ßfQ"ùÄYì SÓ®¼e‡OwmÉ¿¸½áÜê°Í±îq´ët v^§h‚¹Råül<0kô-jUÏ7ïéµ—!ó¸UI˜Š}‰Q† Öulµjõô^§ ,¯šëëºö#Ȳk ýö·¯ÐšßÛùáp¡(å½8ŒÙÐöl ú)sò I­Á®M‘sêclQ||Û‹ÎÐ¥ ë(!Ã);¯ UG!)=c%P‰VÊðñ©Þ9ö!ÆVoåÑ:¼YG„Ì&c{ ÊšºõÖlÛä× ŒÁç0¤Wô`¶øæd IRžõ}_°[4% Û«äM7,üרà z °Èø7k£˜ m W§K½ãÑö’(G¡W4æèâ6Ü©7Ú–.Ì»2Š®JLZ¸«ÌDÖÉ(Có²’Œ“s“™,Ó–+b ‰´El 8REDeêú–1|7z~{oaAŸŽ‚}ns±¡sÖãyØd`½_í‹ÙC&!‹-7Þp傿¶¹sW Qj¹Õ*mš\ìÜÙ|ÐoóµÐKêÞú( ‚n§5–z5þ§ÐØÌŸe—¾4Ós˦$8ò¦»œ÷Ø:‰Ü@ãÞ8¤b¿}àAIØÒ²'RÝq›EÅ£—Ñ[°TÈ7#×è,‚=[åä²ôáI’`²8óßg{Qz‚á¡éW]¾8 +oÒ ½–3¿[øœ2ç[¦ÆÓ¸§Gx±«®m>‰ರ‚€¢ä-çµW¾Pþj”A#úâTº[Ã6z¸ÂÒí%¦MÀ–ô&èi–ª1û•CN®Ùïg;”ìÍEY†Ÿ¸ìntH"eX„E™FãÜðƒ . ¥<#ê³ü"STIšà®¨íßÂð{o€ûQ('Á'‚¢ñœ[ºò•iÇ¡8<–M{„VpÄ`Ë8Õa×Õ–n\‰Ý@>7IUA½Þx%4tN#xÆilzv6gœ4Z8 ¤¡Ú;5¤ºrÕYŽÎú!ŽFÜó@'ñÔ¯9Ç£¨±ÊÛë²>j›Z ¬±|Uî~µ÷ãïhî.H†%½í®¤õ¸T¬V–ï»^Õ†x3¨ÅÑïxK|âµNÞxj”·:ÒÖ¸9¢9®ÒöIã€~hFèß@$ÊV)Û-2™½ž¼ ©ùX‚ Ö²ò·É:•q°î·JG¼P¯f06gߥغþó–ÆŸÛ±QA Ûù•B¯pæÀ„äßÔ#<åJ¾Ÿ16mS{U¼¾oJmï!Þ¢gˆ™ú? —!Âe6ø´'œ²Œv1SAqÌîù{8,=š¢Œ£ÉËAX½:’ㇺò³fý½z/ñgWÂé¡X±áYãíÄtrqm ‹€[ŽG/©€5+¼HPžÿP„·F¾²{U¥´?üs«bU¨‰7JYoQ+ Õú¡aŠ-µ¨¿B~‚ÇØViî”û D¶— ÜC ppêR5 [(åIºf»¶ñÏ—ËR°c¥|“ w ³cf¯ ë¡ý愌=þ0ÿ€K2»óáÅÉzFÍõšóÝ$~ØIXÅ{6X3 –¡eövNÃÛADiÌ^Πˆ~7y9xÿ~.{ö uØ‘÷Þ™:Ðwu#ôZTRušïÍ^FC²4Syk/˜D~[ÙÿC"¤¶¯Tÿ—ÛàÑO^Ç{®/ðßÂ;‰—¯ir^½0X£¬Þúê»~(¥ Ðs°¨6dí»øaõ:fØÖÌíj‹^¼ Б0iÂܨÓ<+Ïàn°Öp–~ëlÎåò˜?7QþOÕà=‰>êrzyÖÛeºÇ¢ž¦ß™5ù¨…²:<žZÀ…-¹ïg‹G˜?fA ?k¬ÏüEÞ¡¿›Ð¥>Lâ ’ÆoöQª?ÓF¦`¥ìÎ%o¬á/ùLˆ¯/ºKŒžAF‡Ñ0çp¢ ÍùJÓ2Ñß=î¯+,Œ:†_Î÷ÄâmÆìÝ×’õW­Î×ìÒh{aI…=‰ØâÔȨªã}ê“âQÖ‡:ƒ¯ÕªBPɰx°gÚ/‰ôŽ^6MŸÅh4Hn9»ØÝ¢ç¸ws,[(s‹øn“€f¡ŸŸnñÚº¥ÏU¤U…¥@Q0åhª‹ÕÖÏ7zܶi[ç3ÉùåÝÄüïDÜ¥ÿÕ!¼¾Î¾S…?a­ ÅÍIf‹Yu] ÖõEp÷Láùÿ‚—õ?©]£&hLÄ[6FÖ‡J{Äp#…ì¼/B‰7òòЗ9+œÿƒð-'Ö¸"-#"KñhÝ•r%Lô•ÝA|¯Î¶§9.£j!Ä]ï×@&THäG6Á„¤?‡Sh'Ý2‰0Œ.Ÿçc² —Ï&ßp˜?&>{}vs*ËÍa- ÞÈ$ïˆßå$9[Û}²ÐX¼j*Û  o§¿ªañ-*³§| ¾8N´Œ“Á¢$‹{çù¡šµè:òZ>g^êáËBc*”­$^~¤*+[e…kÅg:qÊåÕ{6LxsTY#Ô±ß_Íéö{þŽtNì‡Â[\i<£»Ð¥ˆ…Jv…B{­}«8nTÒÞð¨ Û1¤dQ¶ÇÆP@C£H;Òº ÌiÆ~L\,×i” •E“2ÛCŸE¢¡¿uº9BüÀƒÉ‚–ËkWØÒäCØRæs “²*nÑ—Ü@¡—&#t ñ©ðƒ>VXšƒ96É%ãî‘û7ƒ¨”ùI’Æ®™Kˆ¡4ûÕp“°¯—¸6ŽÔï²3#˜ˆðð/;¼ðWã/¶èÿôÍ(hm ü ,‰/õ'ÒãzýX pžQˆn©.úÒr¨-Ì´RŠSÎT Ä§· Š¾ÔS·øo¶mß²Zè ¨•1HCY0L²ÕE)^?À9µÖÜ$^/Û`þX^¸h.äaDéøSå5V›öËõJÚËÊ7Ǡ订nåîe*ì8Í©¹–.h«}w1qcp~¯ïI&ª~• þ–¹U¦¡¡¨`ü…’0˜z‚ć¼½vŸ)7Ô€€k|cñÛRüqGïYVDQÄ.ÄMoߣõËZ? gÌå¥3Š¡G4²™Fc}g‚*_­GåQ’€¸L)JB·Z'öÅŠòèöÖ0¸C»O¢ ¬ªÉý²”©)L6ÄÅáú{Ó¼,Q³¸umáÁèS"rŽ-R®ðqâ·™]‡sü3:Ö`qdÝPâ÷ ÏÌ*3pèÕ¦û DÙªŸ¥›õ"LHäò¢EÔªÍÌã%}bªž=ÔĤj¦iwÀT‹Ï¶5“÷/銱A6áþ\»1±â“x“‡^ñ,Oâ¤eyÐP WÒW»y¡^‘O KEŠKþúˆÈ¶1ôÎÀÏÉo)¶5£3*>Ì”Ësú%× º ýOùa­d×[G³v-“ˆÙ)>jQ„4 º¤Þa6Õquí¾ /ÙeZ£`RéÖÇ ©øó¯Få{šjµ–S+èLºBüŠLÖª| j@š¥½6žž7R½ÐVRÝ^'r®”¹ºíqéÔ¼z ÎÝ] –Ö¿j&¶Þ¼-›n+=Ó::šÿçî;¶}eµ^óN˜L%OÅU†íxçì¬4Çå;Rò©ÈÄv^”…ÄÞ8Óñr4¡.R¯šú½ A´nr"³ºïÖ4¨›g@RwjڭП.ê‡ÑeÚ­tpbÂô\ ¹‡~;E¦ªzýŠl·TsÅ“B¼“ÿH\F/Ø„Ð.§2CÇ!%"!Àa2ðÁ;°^mþê<„[Iºh•Ž}{ lÛÅÄÃÍh ÛËÇ5IãÊåö~äê¶ótF}xVô`Ö€ñ¨¾,µ%VÁk3îz$·^Í [m–âøLòøpö^r‡|jç H–jŒ>ØTž;á Ø#ÑÕ÷øñÉM?šØ#ekf+ï€m'ýy50¬FŒLÁW.cï$üýâaL*EÂe%4•Ì™¸ƒÕ3ÈŒr•%„ysY‘ù—$ÑpF~.Kæf1ó»1Å q§Ö`·š#Jû¤8< ñÆÓ#CÈGÏ\æ„HÔ¯F4”À¯•~¬ ”&RBÁG¾]õ–Û÷8؃RB/’$Så2+ý¤¸tEW5ií°*^@B1]©(% d T z6¸Ê}Ðù…ÏÍRåÂÓôÚYÈû8}òI`2Ç~„!Äpð]4Í?à|3 ÷«Ñwæ’c^ezàþ££éÓˆªðº´sôeú´Ö茥ݵL…¢ÎƒoÊvS”0¥Ž¥^\]¶A쑌ÿ}öL¦Æeö€÷ÛÞý¹„=ª´h$tT¨~£]qOD`Y…p;F(3Ê4t­ã+22zîf[×!¬êx3˜Ø³IÿIUä§¡+ "ÇüëÀI1ñ¢%òß'¦ÔAÑ_Â&]Xÿ+öèã½Õh/ß{W¬.m6ZÜt‡Œ53¾i¦=ÕktñÛ¥ªþ‘IúÿNdŠš ïÞƒW–df hfùîL<Ðý%™Ê3Ø`?e“Ìx@AEÀ¬e¹˜(l{Â@§6`‚Â]C£ëóÒ´3DPA2›ìÞ¡Ó¼‚å®û­O¿ÖŸR8^ï.®…eÊîάàŒbh±ÿç‚3«:[† EHÖœ´üÔ ÅñÄD¥Aé§½‰ÞkÓ¹V¤'\+­p“Šo£“Û©´»RôaVë•ÅÐQÈë·[q,_fHh²Be+pC šÇ)[ïÙ!Ò‰)ø¢‹ö•Ô8ócÞ«_Ð^’`ý¤ñaÜi°$.Ä âHc9«v}?Š7í2÷E²¼¬™ HW>‹¸fiùÚ®²2=œ‰ê÷eo™U;êCk6ù'õWnD—¿0˜þÝœð ‚AžXykÕß´2%ù}ø ŠM™Z9ÜMì‚‘Aè@ûm`gYÚáÀf°-|@N%âSí‘lï’1½æ;‡ºÝò¼»Ò«'ÝõRª 9Z–Çd[51ìïë¼1§ý©¿ ãÆ\ˆÿÉqYšûcôâ)X=ŽQ§þ¡€ÅÅz‰HqûùëP€wí#Â7ÎUiµ%³"åp5©ë©©|€*Ä/Ô"åÓÀ]¬zþh.êUGUÃ^;ç T¸±͂ㆲp•í¦°Í õ¨]kM½ÈAä³AžQÈ9eÞ*Y¼†ÆÌÍsÉX.ðO3vÍVFª‡ª²'쀉E”†ì`íÞµ²_Pmy!tB´Àb¬³¦×ÊB8“\2ÑÚ½+€íQ€{1WÒý uOÍúu;DŸŸeÎ ©a ¨Ušªmt"IÞ•@ö# Ú(¦Æ>’Ü;²Œ@ì³—Òú ÖQ¬·‚Qyp òœö¨‘7bßm„Gž.aúÚ￵ú ,+—"MÔ$ ¡ÀGÈFGù³ìwÀIÁ¿%¦š_F­Êvïãêqø¢QâõÚ8KáskMűl|ÇU›‘{Å*Ï]E{EéDú²6Rrq š±äV]‚”ÑÞ÷éY…`e‰IÄ& ˜ÎævºOèxÖÔMÜZ¢€„kS¼ÝÕ}WÊ3ŒßÍ4Éò«÷)eÉ㮂_÷„A!cH˜˜¶ÑÒÛqp«²O»D7«Ä „¢†…/§S®¡KWät·¶ú^6zAZ1Ú*‹Ú3LÌ–5©9Þì®îi•:;Í»-.z»n´ ³—¶å¬OŽdȾŒM¢=¿[ÒÌÐELsd]N{ÈW%Qk²µÁR2Õ¦ZÒVƒâl-™€U§´¥‘‚@X°CŸÝ1j;Òr#lóÿý¸çÄ9í“FÕ„°§Búgÿk@Ö’½ÉZà;æ§­ÁWѬ=VíòpÂsd4 ”Œ¥­@9×SMû%NÑíp¥ÖñIµÜùP¦—Q'?Öy@ˆ6ùÁÇ&9×]ñ!VUi1‘:»yöƒ²êë¹Æï·‚¿&‚©Rg. ¨8/•²õ0äÆծKÉ×ÀdJ®ò¬Çéô7e³Þ™m[`tcwФàt‡J¥_G™?Ž" âÈŽ^»Íÿkû)WÃÐèí–W¸ ;œ·Uü”|¢}êu`¯¼YŠUèhë8R÷Á²ì&E¨óËuë.œqÈxÀؽ]¤Å¶vãj,D(š£A«K#å“ëLßFÒ&òtLvÜyܸʰhÑš7Áeu©vŽ"rÈM¤BÃ[£Â¸ÖôW–3Æ*Q¦§ ŒŠÜ} à{vCçÊ5l D»uª ÊÕyEÔ ÙÅ™ìObBÃ\lóUu­æù¯ÛJC{NQqÅgð0Ox…im|kfÖLâëàã!ì ì\±¬Ã×¼ÈFÔ%ãi‰á…nÆÓJf²Äöµ4®!Ó ¦>Ö w0ÉBˆUù狇ˆ"¬ˆæM K+a­Åõ!"ƒ·}ͱ“DpAÕÖRtýž_öÜ6ðŽ ÆÂmá×ê·/ZyÈ[ÕLÒf®ìûŽæsòh˜›ê‚²òl+&Xï.w\ï5ÛD³‹s/(•+ÜY9wxu8÷­(0ÙR.Y”äñoŠhøÍr7¥ øåakcíŠgÂ…¼cLa,‹åZ3ÇÒ m^Ûe¤OÃ+ÚŽVõaURé/ešGñF JÂGNÿjÿ×ê4o24°ÃLIC®+a5ïˆ(€#‹Pm?‡|€ =¼0"L±9|é<†àT¢1æ¨Õ1JØC<…߃&¢S²3³¢€Æ¡ì*ü¼žÿ²s?ßl–jèmƒn©àÈUOz(‡>³±—Õ–éRߨ7¢Ù[@…ïT…\Ö˜ðy}üûPcS…sžt@š•ówM4/§ñ`8X·C-*/‹¶®ÑY^o{_«O¡Ù%íäï[@šçÏwup×Ô8©â‡3¿˜ˆ‹Å“Ü@ÎûJç ¾‘Ÿ[º nÖéQU€¬±î:aß q½üàˆqÏZUšÊÝ)#HâM€'¨ôÎg¶]Ùö#îî6JµãU!VJ’Jæ•a¾Ù¸ÿáVkÚÈi“H×ô­õíc§z.¯TÝ#ÀÆЂk°€^Fu~•áðÈ[í–<@2ÂQYa¾F$ÜyùbP‹!Z“‘ëOÁÁÎ;vŸ€eº]bIå³éE¬Î@š£>c”%Zß¶ÈrÛ@nSjóâ×±½ŽÊ ]Äü„7·øh|‹Td"³#X¤*S¦{ACl8é&`¢³Ûû Öóœ €É1ž³A"À´!:+'êR¬9EÚ³«ÁÌ?åÉP¥E~,öG/Ž0¤?ú\Î 1ôIíµ1$?«æ×„{–ìQ»Žîoy6nyµZ Ÿ„ÇB›xIÝœ·iM³·ç:Éc…´_Iâ€?A£'û—âH‹ô;PkÀ£Wm¬¯a(œÓÌ—e—‚!IÇ·v\àŒŸÖõýH Œ_UA\úû5º[¸fÌ~»\>cÉÏ%’ˆÂ?‡‰Œ#²Ø«NMAüð-¤€€<ô°Fà±2‚}ëíb&¡u¼1z;#}1,€­’uu c¦–ßøX5 ZŠÎG~˯_Z“¥UÛ‡¸KUϱžæÄÈTà)ó*³rE×÷Ï”¾CRLÒÇ<ƒ&ÎHÅ KpôFR+Fª&½‡<(Ù³Z¸«7¾ã#CÛŸh¥Ù4ó9]Êh®*4|ýå"68¤ð'—<=K@ãYNõ»B탗ðÚ0X×l"Ó4qC´T§¾}rA«­}­oô4 âhê&©×Öû<-pŽçá™nd[Uò+ÝÑÉ_X¯KìLm]¡uµ1|u…DST.¼äåwë2¥ÎD»Ú;ÊŒ;åD†Ï¥ÆWg$ çl¯ö§‰pÆ[¨ÿô W2ôºð“Zý”(õ¢éÃëÿ¢_Û‡ås}€ã9³åWPÚ»ü°ÊŒÞ*å)so‰ÒQÓîfÕ²³›í)lRDÓïÉEg5]¹À€)Ïœò^ûu×"ÅõRΓywùT[Sóã,žÔ›¤Ó;4Žú§Ë>±<UXn*Cñ´ðõŠ3ô€xÂÆb.~¿¢¾”æ$àŸQµøÇMoú arÖ:Ú¼;£yæùó 7ZŸaë6´^ã[Ê~Må0)&ÜS»÷°¨T»kcó¦ÂJ æä]%|êm/4 Db8 Cm7s©?„xsKÃÃeUg§BzˆÅzÂÆüjDɧ^¬ÖÄš ˆª©3ôšyó Ôo¡($ÆüW´ßÿ£OQîa˜ƒqOÓ€’>Ñ-Îú›·P|­ðÿ#çâ íÂ"Us߉§\p.V]ö£†üˆþžáÇл™lõ@j‚\ ~ßñN‹Ç× ˜åj`zÅ(€Mî*WŽ–&9_cb^zý‹-}*û%~ì]á­ËÜÖGʼn³Ôýò ƒ„ËæGlôÞù_2HuafBsPYÍŽòãÜŸÖZž ¬?ùî\†Óª+4h—÷h²^¬XÛ¯·t‰ÆØ@Ç?Ç|F›¸(<9ÆXÙôv »Ý9IâÒ+jRrKçÑ¥mÄ'ƒÑŠåCZµõË81ÍŸº‘EÌîf¯å*CY8¦@¯ì/A‰xÂþ”ߣçp/ΗzúJç[ ‡c#¤?4h/Ã*Ý Ê$/žXe7û{˜‘SkÞÔ‹ËÉFÂo ÓÃ^×Þv2}PÆA?B¶•Ê/ Ñ]Q ‚ž‹Ló ÇzhAÈå¹LæÅ#ç]«HÎ2ºBnè¢#X´ªý£»šºÊˆ|°;æÍÎÌ;$fîìm Œ:H¥²îÍûŸ?Â;|(¥ î7£Si}ü0™®£‚øû0Ò¸r:QB–çõ“Bÿä➨CtåöšäH%Ö`®Dþ‘…Ò0Ž÷¡3˜ ¾ÆÂ¸Ä µ- ÍMkû›ô;õÅ€¹"hÉpY¡kë³ù|jJܤQ’OÑ•¡ @ÙÞ­V¢гâW¦áÚ+Ë¿²¿¬Y%ø.¥RHS/âL!jJXgnvUî³³u3;*\úžàj0Õ ¸ðñ¼êr þèÁ:µÝob È. ‘Zã—JjYÄ›û)2ŠV(O,«¬óH~ŠAT§æ´@¼)kg¿Ik’˜Sþ³Ü›Œ½  ¡W¨y¢fË!†‚¦œø'€«ž¸.¤f»ÎNg¹}ÁÝø[iGÀÒ‰zoç)x;‹ìEœkØB¤LШÑ·ÞO‘àtrŒ\nO…e+‹Kùu-¹lAÀǘ)'6 qLó-»ÚKÛUíð3é»§¬Õ‚~_ÝÙBx%Aµ›· Ë@ªì Ud½á£F9,cEt’ùÞÐÞ¸°»:øìê;=~vÕ:8" *.Y ì6Døå@øyœ¼°-6æÑ‹ˆè×eé6°>2ü3ܯ ´¿â;2¸%ÈKšpÃgÝ[åÞmØ45N(êÀ¿Ž‹^ÆËÙÀ}„ã,'Ãð;Pru‚A­ÑëF¦•ÈAñø‘;1/•Ä*ìUéVHFÀ¯B&ƒý M‰­ß}쬄äX‡ci˜xÀÜ‹‡}¡â^0L°è†bpiø-¨Œ oc"*†–J•Ãåõ„^§€“XWZ¶ñrMV©ÂX§ZÊ#h4üàYär¾½1ïÝÓë³'´Œ¸1Ü!5p‡8lðÍÜ8âŠÃbJ©ñí©]án¼ÉeÞ9@fÑ"¿ªësW¹;®*ê½f…Î#¿ñº:“‘ü )¿‰Ùü¶ó—°l¯oì!íüã,¹Þ²RzÄ òÑ*¹æŒp¦÷ê ™V)ÍÏ'ê,S<ó§T5¶D^r’|ÉŠÄ» Vbˆ£wåÌïdL ÁìVTÒ“œYP ¼òNdUÀ¢ûhm‚HRvòùk9Ù­¹îÃʹ^§I¶kesÀÈ 0ÊLEÉð±ÆÏ¿BV#ýÌ•F­Ñš¤v’Ù¨’£þ‹JÏâÙíWh2¤‚tA©<ž–ð4ÁìœjŽp´í{ÝÄu V±û H›¼Ø³ÞqÿÍfX9_èè“f™þ#ë’[}Y˜5!³{ÚóÛê[¼…‹7c‹|.Ó‡7DZÏ[£u‰[øe;À âÁî»™èmK¨?Ø+ŽZš³™ÙŽ¿UNÁ2Ë9Y2ØUÅ[ÄÛ$ù¹ë¡§áúDË;6Iø­>>BÈ@½² ჺÛhÑcÑr˜²Xb\‹[JÖ ›«ì“}WTrMƒ“ìoŽjÂz.=–ñ£I q½¤¶ÌTÒ'B‡Èä¿Òé]‹û.^%v¦–7¿(q´È‚oy¯Âe1ª–§Ê csª¿í™ké‚ÿ;ÖK=Jìµl5é;c$RG¬KpÀâÆú­y(=†h[Cw£×ââTk롺yYQøR0êëê0Hêä§ü˜ê­1ѺÇ”9jOúAæù&†¾!^Íݽ“°DyUtÊ¡…zY#¡OuG…×xª:u8C(ì,ˆÕ¿!k…EI*ÚQFE×4™Û ç¿Àhá–˜ÅZ" jå9š´ÅöÄÍs»‰»Yæwnë÷#ä˜w1È=X2bÂ,BøÔ£Ç–‡îü´šÀÔÛF°bcÿ+Äyœací[¼¤(=aÿнj­(LÕ¢Þ8;q-ù¯œl$$ªn »Ì5«ëÛ´ /ãYM¹/É:[À’ëÙ»;r·šáû™£†Š¤!?&Õ³¿83àìm 2°¨ae&ü€ŒØ-‡¢í,È:ÇÝ É—å²=IfÉH¬a_&*æ‡nH+ßõ}VT<Ø>Cé~HUhp™«²Qá©¶õ©F70o´mOŒàÆ;s¨Î¤bNÈÎÞ»¼[”p yÝ„b­ÝLš/Ê(Ôh¤ÀˆÏ?P ¯±sfçk˜£ßsõ4w¶ca˜ß•Qñ—Ì!Z£ä`bad0b}äVø¹µh½²Ê¤·3è€BïTšËÌwy¬MEPîd“ìnY¾¬"ðBMVØZY‰´>`d§šßöb®N4="Ÿ)8„‡ƒÒ³ÙZH©‘q·™ÈE:ëæ$¥Ñø¬O‚QF"»Ç&7 øOªzÍK6îLõ…‰Èó¶:ª^Új¡Ø;ßž©]¥Š²ÜßeK"8Yˆ‡™áÿ¤»:Nä5 QˆŽGK9âçÚHžãÃ+W‘ŽãLté~£fPm«Ô û½ø4©4c¯5xòú×~Üö%£bî‹K©‡~«6œjgßãÛ¤‹ÝùQïÕÕ ’Éw¢úÛŽÕLöX‰ù‹4&j·Š¸±Ãÿç ¹šÅyÖ*‘½{ŽíDãÎJã—{“‰Ð(ºI¬eq²óÑÿ56ö`h Êüo…ÜgÿÙK·`ª,}#Kf)&U£æŠã¾àôñ¥·¥‡"«¾Š§´‚'bGüÉé)9*i¤|Ù¡ìæõ¨è3=¸&£\êÉh«”K¨á“oÝpt¸¶é¿êªHxΚÊ–zÖCåþ(ÎL3ÖàHÌ¥õ]†Ì½S¦ ¿ˆ‚/'¸Ã¾èŠ.«ô…>& ãýGiF+Qw„&¨mÈj O‘%Rèñ8qðaщÙ§¾3`*â^ ‡i¹ñð¹³s0ø…òù䯿„vl\¬Š#a“8Î@Ð2¿“I #éûÙ‚úG^žY«É2™™€ '¸åXx³=×½bT¦ª5ëFñh![wøWðªµÚcÂVfAwby ,@ÇŸ1²5DžìŽ|¥ÌÔ9µ` THíÌÙšPÀŸÚ³žšéÌ/0+¶Áðß ­¨®…ÛÏüÂ>}ú1pJû\¤“žQË‹‘ÌFZðÚf¨Ìfa§o„GNç½×>^GÀ™Ój_+”£ÞÝæ`Q$ÝÄg>‹â:§ñU­æ4.qï_H¿™þÞ‚I@&ø¿Ð¹/?´[AB{7Äã|0¯Ù0ÛÆ,Ž3ÛЇOõ "øvº".‘UßÒ:½aîpëm(3*ôJùøÝÛr,á™ìˆ^–Ú\ÕÅmB?{O™]ÝÂáø\€Ÿ7²à PQ…<.SË0Ðø#>‡ë«ìÏzù ð]1’7´åÇ÷«L8‡gvŠÌŽM·[ÈþÏr êÜOE׉—à ¤½LËWï: ŒWUëÀµÍžÀãd·•Ù)á`ÿ–Ýݨ•·¦˜\¥‹õ@%õË'W8â1ÄF`éºF/oẟ^ҟ؃sù ¦›­Tû`/"I‹D„[XŒb—˜´E°p¼®Ü“ª6yÚ¼Ð\¯u›´Ý€ýgI<ÑÀ;¢t^™’ªáCA+£°€ïuËKtÁ“¥!¨†Ñ}ªa¤BF¥ÞCã ÉÕ7Û‡×mb_%a’ªÿÅ#ëu[ŠÎ€h0†Ø˜EôRæÑ¡«¿t“=ŽHüT‹ø‰Þ‚Æîƒ“ÝK›U’Ì'£P,¦µ~ØR™2¾3¶äéÿVçúAÁb%m1º¨÷‰}k<²/…e>7-^ËŠ³xHfÇMÂäü‡š†×Æœ¡,꺤&7 ¬^+µ+ìhºÍA¥­ S¸xO£HÙyà ½O±Ô$r•õ½<ч¥ÆÍ±bJöŽs>«èÖý¤}–`ŽΣÌdémè)7¡Õ ÙM¬èá™^ût?^nJ¢ hrò4|]46É@Ìgz{JñU(,.éê}iùDÜ>.0 Z×磂üƒBLÇT3áÙãä@Òœ *[¿÷ ȶQü—/Te_Û(‰ï+Ü¢-²æ\~t8Oü´"`ÆöAÈï5øX³Ì*>- ¯ ¼ ×®Õ+ßjÞÄ[ñÈ’3\%ÁG5ˆôoŸ°7È S·yÎ/+üŸ‰iPâ)I”ò´NÕàh#:‡û¤/kì2ñ¶<¦/ ”;‡äºkL±ÞTWl³NÈcàË`B]c‰OItÄ EC_g,8hÙ»-¾ùˆV†=ƒäœvö¦XXBÐiØûâ…w£¯©V»ÑTŸs|¢Xmò …È…hd,w‰ ª¦·„o©Ñsব^°t6Û00O&»+Ö‡é‹`Â-ýZîü©NDsê‹™$…]W ¸Ù¶±sQ”„[ŽiA¬6SøþZL´ yŽ’æ\o|Ú‰Ýè@|kL¦-–mo÷ƒä˨vWbSDZ$x$©¦š·ó$"€…S-=#|‚/ŒÝƒÉÀmÿ)bù/§;îw!•jâ8™ø¨:ÞœZ¯uš¥ºÆOVDu:n¶Ž#ºzØ‘†€F$š…ÚAîJØÙ!6(îîåùŒx³RŽ:‹k2õ’"¹³‰ÎW‘o³Á{à¦!ȾiøwQ³¸#T'X5ã€XÖKl©ÞÌ Ñ}AGŸ†6T.gÒ:˜N4ßa’(¥g1Ÿ–—õ³zÜΈ ›sô€M‡+Ôv”ãùœ]Ë; /ýùA"Ý,å{ÄÛ/ ={³â7'ȯDzPŸ|²Ùæý§ ©ºÁ’Ê”Z®Xâ?rµS«»}KvcÚµI±ŽÛ¡ Ü” œ?rS»1[`ü|ÉQ¡m»¤{‰E7ZM+›ìþ óˆØuÒ9±›Ñ~Ôt¦ }"‰cØ^Æ:* úVÄÝ0¦íbÑà¸M,×Ñ0¬/içL\jæôšü½7¶¨Ž‹ïóù5LöC“Òš†k=9âCÚ­ÄPAû¬5޶¡T?I’¡=Ëû¸J™'Îù˜ÄDò?&g_§x,HDëÖPI’-6^÷.*¾… ŠT ŠGØõã<”µRKíC%äAjÜ*l­C ¢Í{¢U|`W—G}R¹ªHßþ}>löÑ“”ôžh‘/[¦¶fê…Azyr)b¡u:^;yJÄÛqF{íø òyªášÖlND£]wªÀ aŽV$6¬¸/Nžø‘¿ŒVŸDŽv½ãBP— `xì6(Ž4ä8wU«uOç&Õ~é×Ïå[nà°öaÀË^ýÊëô`ì‚/µxCJl|© ÌhW€ÔÑt°´h­ùq6žY-8?RìL§§=Řh6êi¥oÂ#VÓa$„Å´Ããü˜ç g¡ÝL.»§`ìëÔw$G¤HÔb2ö”Ð4P•Ha¸o؆ûú5I‡°fKFíð/óÛ×g…ª€x%oS;n²öÕUxøÖ`8ó¤˜&H|ë4`"íÅÔOn!§‚¼-p6¬4"")1ýùÖì V½"ÎÚ[·°ÕC‚«ÜûþÐú¸¬i°Ey¡Qó›sN½ o'ËJ8"&Ká㨋Îz§b¤Î”=æF¸]CΤ<Ú£d³Î$—à³Y¹ÑMÛ„çr¦üÓ¼ÜnûÓ)²xØÝ)Ow'1†»ËæßøéK?1±TMMÝ¥_c+uÍCc@»§AjØ•àF‰¬1ôÈ©æàƒ %#'-L!²“µ=N RèbÒ>Ú÷ݤNðB¥< Ÿ‹Ý®¶ Ž›^ "“­œUɇü÷Š ~›Ô‘ ªìæ˜Q5‚4×I„$#Úsf¤m,ŸÏ´×ßáÃ÷ÒüC‹ª|E†MNÔ·Ç.¢œˆ3Õ9Iè›E‰DDþxæ; •m¹_$[Ðf!ÇÓÑW3G@#]Õí÷{˦1Zë˜q$ÇL¦ï“oŒ§Ìm#].k~o«Ì}A4P T_ÆLDRÙöõGoD×^C•˜–ù$þ$ÑÈuj–N…¼¢.PÞ°y¦!ºˆÌæ eË·R¼ÞD†€Ûæ´‰€Ç<*‰À¥ÕG—®i·çé2%*ÔÙ2޳çûÿÛ>G+Óu¿%ÔÎXa$€ˆ8oTqµi¬ÕŽ–žat«’ñÙC:~/—yQ¾³{³Þ¸I&þ•–×w¸TVAM /~©´W6C’è®ô¥M"ÐU-ê·–+Ò¯èôŒÊÀÚfâëCNÁ®ëSSÌÎõIùò0Dz®ä ,aÖ¥“ߊ!…é?ªƒÉ÷¼ HQ¿+ÏÝ«^e Î[;Ä ¬ZÏÄò¸CHD¢Xšø@-²I;Ë.´Ø"ÃÌÏ7 ¢ñxÓIìjìÏÿ lôN¤ÙYHR¦Ý4÷Š éµ4îÐ=ázêµ¶ŒUç§DlAWè!dþüj¬ñ¶þüJU ÝQ5¿ÕKVÙíâ1ßwøC“Ñá Ú¾ø¤/šk°à©K¼¾!¾ ¥ª /G ‚Ê?s»ç=pgš¾W ¨ÇO•`(ÅHÇOÆUJ’&Ç2õÃoµídX–ð}8 Žr篚wlYéë̇2¡x¼Kˆ‡õGƒ[|½Ìëu`…Múæ"d>²îQôD€Í«³9ÊS<_^ºïsvÜýp}ô™›E&刦Xn$©g{:Éô÷…ÅöZðž(‘³çžÊdf2²ª4ê‚m˜ˆ%.W dâÌíÏæ´*fÏâkf)ÝÆ³Þ~Ûµi¸û’¸@¡[ÍC©ºCn«Ø«auf¬^‰T½WFB‚L¹ 8– ]rf(…†kY ÄÛÙ éKÙ¼î9qÕ‡Àsåóç.”‘×7žÂ"&Þ’tn5½ U¤A·¸_¯=× æ¾4îp>úª&$S;ý‘*Èí-xÞ ·qtZšÊ©7’V’‡#?'àŸÇ…PH½P?e[äÁËãíq‰†ñöì`˜H¢¹´|Ž ß"6vwŒm®rH­„‹/•%õÈ”©ÀÛXQÆ‚rƒ‚ˆˆûL5bpÊ>•`…†ÓÏ®úMSj4ÎÃôu圊ܓ•YOä 2,þ³Ý`ŽH»rÍïûÒ6Ùþ-ÎìPZ:j ¹Œâข Ä“%YjoNl 5ï… œ(^q׽﹜÷"¾¤\@Õn8†ävGÑóät˜®f¶aJLÆ$±ÛWâY8©* 4–J]Vë5Øç ©"¿ùGÎ3ÛÕDƒ_Ì…õÍšµ5yµo;ÐãbP•_Rì›úã×b¨‚ÿãvN’ë‘Îâp—‰²HbüþÁûTįü‡1üBN0Ûð¾Î]kg©Òo‰_ÆÃÁàW#?{mxSÎÌl2FõcIŸãŒâFižÕ~¢JÁpééËäF”šf÷/QN¦=¹‹‡S¶„èÈ'åß¿Ÿ¼•|Ј çŽÒL½^#÷/»\ßÛ_rȲÝÙ/'*K—¯ê¿“J²K&N€‹cèã¬ÓÈ -Ì—mT6f•Y…®?cاã|ƒK"êýk»çÓû‰¬wfsœ¾®p7þ¡ÒƧ&‡×ÖtîEp7A§ˆè‹l†m÷ßÙöûH¼þ;Î9àNžiÈÏâÁQœºØðØú4Ì!!pðÅ›°ê£Ö0(÷˜Öì 1x¶‚¬Èö7‰{p‹À€¬8e×h}¾¬ŒO÷y2h<¶û®’sNj? ›$RîCJ±Ö¼õÁ½´;ž·®º%…‰[Tƒ”œE¡hNµA¾D'"Çòa¸ÍIÁe‡Êó'Ê$u3Ÿ~»Ú¤ô7–Òßÿyñ@–¡ú=©KÔ_Þ‚J¯ôÃý†y}pù'G,vO¢'“˧,ÖÖLÚ=­ ï³…Å#è,+/Ïh”[‚l»o¼ÂÊSÍæ•žé\@Ôû¸zYmMöÇ¡[û¨@4'¾í¡S&„3ÕïaYhÕìqƒÀ;¦g ª÷ëå³}sØKÕLÙé•óD©V`¸W#¨39ÜvÍæ˜Dxý:u›”üÊ3Ï5ãÐŽo[X C '}±ëVøc™Ó -=€Ÿr7);èΧ Ñ °Â=7=Ókë+Q+ÙBçG-EÇ˱eMëÒ Hl‘Šò˜¿>MÍ7;Þ»bš÷Ÿñ©É+k8°â7Ák^Š›þZ¼¿Äò‰†â#•„Ä€¾;ã·›B0HV6`õÌ;g ¿˜ Ïï¾UéHf¤%Nõ|‹K@Gr‰ý è¨+rÿ <ã“ò t/ú?0A(ÎûxCàçŬÆ]‘V½£ ”õOðŸH3¯®þÂKà²>Dk>²ˆÒæŸZË<ßøùfÙÇ¥q­ÎÔÍdk—»Ž9 2!vªkw_Ę»P¦B=¼³›¨¢’x™l¥ ¦ "EåÓv—•¶ž©l^ºÌ açü®Â"Ø¡Bû,Å¸Ž ”þ²K ¹íöû+g’M8*\ö~ñÆn§¿.|tP¨ú\?XWhÐbØ5Á¶¢ø(Þæ'\͹æE³÷­vâÍzÈjtë+ ~gƒŸüX˜„…JŽFßo£od •v÷¶–'íO22Á­«ÞCCNV‹I+D¡Á¤]p 3ýͤšX"—«JJ‘y‰Qœ£â–!Š˜V(¢“¤o|öÃk I×Úuäõ>ÞviÄæyŒOHNñÇ×ñ„¶æ÷ïùEh”¤PÙ¥7ª¦-Çë´²„ÁÀ#¦uŸNG)Á€­†~ì jͽ•„0¯¿ôßO¦Ö~C «ÉMh¦Ï0ûáéàZ)™O£Ãúp¦Â¡¤Ø”2+A^fF± ãHÉ‹Ÿó8¨Xß1Ѷ¾Wæ2Îrž,Z¥bPO:wÒm»]¨¥-ê6:Á‹™›\§Ä :¨Ó˜«pC“&’b–ÁÚp/¡·D6n¢øZϸ:ƒ!Yó`²!á%ÃI{SðÁ»V´]ü½U_N+½=-7À¥qÆØÚ,•-úÎI÷NÔ“þ1³@äð³3‚9˜Ò³'ªžhIr—9¯!Ÿš¥·Da?9Ò.-@‡•ˆ×„¶Ï 8憷!/5ƒC]Cý¼XPSÚ:.V÷Y#íøE}G¨=1¦›£nYU#]‰Ãù(\¾ò«v7¯.Î<âÿWaóVˆC߇Ë•}”Þîp '×Áh¸¼A6c•ËÎ’f˜oâ@«¶ Vðy·‰Pëël1 „fÛÄ®(YDTRYYGŸ„4¹>‚'ƒ4Jþ׆¾ƒK»ºó/D³ZÝe,7M†¤çFØÙjhŸÉAü ÆèxYêÛXâÙÖ=*`I_JLàÁ'.ÖHËÊWœûêzó´:œÐ³'6šcàÌÀôÚéuXýZx¦àC ¿Žád—(êI‰k–‡_$•×Ñ(ëÖd=Z88ËCºÆw>w§Û© f³ØǹÇY7¨ mTÇÇì—ØÆHæÉ+_¦ìÖaäÙWˆ@xmàdYS9qª5¨4K'º"’9åϨ‰êVuºMqÉ‘®º¿½NÏxË”ýåÔaèt:ò¡R·ãþtðÛõ˜†á¼¹-Å" ç{KFÈ:ùç£gÉrq#(ögZ•ÂÚ§ˆîL–Tiž¼jöž-@öš^g›|Z^…§g¹Nfñ¼aõÍZÃ×Äî€UXì1¨£k¶h÷íûâóÛ¯˜÷)ëXÒˆ²$ãu!qTL9öï´¶¨I{HCøÐ»òÙ÷·p’„¡é ùG¢ ÀV…åJÆfœÂ{´;9úÏ=t ºF£SèµuI2dÉs Ri Ÿ‡\§‰¯ý“©äl ðj*ç#ˉç ëº ÏË Ìä•»™Cñ>꡽ýá9}î´¼»¿ÿO¦‰`¡#;JjÔmî[·š?¬R˜·#&âïåÖ6¤y_wBT3À‘Áövñ¢¾»çoýQ弩'êÆ™V/¯è})ëª{(@bcÌÝpø„Dô1~ñÛ£y»P€&Aq½¢•^6¥‘Ä©ÖB9YëœWu ƒÿ—¸ý‡æ€fÏc5Ù=1Ùï3Vöd·¼ î‘æ+f'—ª0¯­È,7«0þ—hædB¢îѸ= >ÒÏXŰ~å`GíK´ê²ü› …g%]=÷1ŸÕÞ»ÂÈs’ÝR¹¥&&EèØæ èaWò óuN-¶\«xà•g‡lkYæ™@…oÈ$ÙMîQorUÜJ9ÈULï0Ñe¯Ú’œtúÔoÌXñny]È"R>ã»ÕŸŸÃ—ß ov…ì3Þñ¶;~Y)#°¿§’[äžmü»¤Ñz¢^O¥åº)x I”i)–ðS™`Xð’¬ÆO.Ÿ®Ølæ‘x‡R™—q©$QŸì&1r! ü¤“ô÷-R«×þÍñ×ûkÅá»–Ð(ÿðC-àÁ´H”á^:ìï^‰h7s©UNœR›ÚkÝΩ¢õØÕ%™¿[ñ§ðØ¢yŸƒˆÕƒ]¯Ý3Z9¯Á¨ëâQ}ƒ–qcm„Ù”ü§’»‹¿zV5H*Å¥b3ç¤y@H«]–ˆtîtcCjÊÉ 2ùþ F0•™­u†küÁÃÀõ²®MÙÛ+º/C Ý"ûÉO?°:ƒ)‰ýèfky™Ýq"çò„hLy¸¤0 ÓtØ]Õ G>Eü@ ­RǸ@h¦^ ©èÚÜ#ÿéSN5{cKA>ø¯nþÁŸQecáPcê»8ÜT=dêì϶aØÝ+“[ƛخŸ’Ã^kfÂMöjlÿk®Êñbò{ÌíªkÍ$a“ÒiaÏú¦Ôß–È>C‚—] ¢Á1•6 æ—dRã;ás/i6¥ÉfáÈ kˆÔµt6O‡kÈü¼mtôt’Î ª¾}õ~“1#[ Ù]¸3@7Z~™Yß(™î¶É‹=úè_}šw¤Üu!CKDï8Á~Ù°Måa¶ó퇻°ÎêÈØ’Ž™ºÑ ÷æÿH‰0Éä/Œ´’äÉdöqåç¢_OÏR:ím>üöJй…NaõZ¿é]ªIÃìf-q Uº‰ùlLÖ]¼Ìß.¦]W¥–=ºÖ¯ÊÏ2bž¥Ý±\æ=KÜU—ñ ··é\o)%ÝÔÔ¢=þÏBÄ]{dÀóŸçéžÊ†’–yTi&W¼L.b& –É?w½?·âçDÅ<´Ñd\ãÞ3ÎâÞ¾€×Q4M¾“)„è?ËO#IÙ {4ø5ÎÆ}"»ÎÙwuâJoa»ˆj\½ïáTi›ºŸŸàí°žØº¯~†—•Øwß¡»„- ZíjéB-”= ûOûzu)¦é~åQ>u5žà~VÄ!,L´Œäߺsñ›77€„*Ü(Õõ šåwþM‰º\ú ;°bM¥d±¾ëÎ(Ðý›°H¨àcúg­ýE®EOÜðwf_¿®nµÌ*0 ѳ)ÓâHø‘Ó3ó™¹$'ÜÂìwå"ŸÛ RP…gH¬ÜC>}¡Á?ìT9b;G„@ð@+&Måãžóç&aøaËÿ冔ÛÔƒ*oþÀ^BÔˆ]7á"µ@½šqˆ•Kx>Õ¿^[=„Çœ=®‹~ÂÒëmgý‰—¥ôgŠunŠX›ÜŽ/økSãÛ#˜³ÁÊ÷':u­èÈ”>NjVˆâÀ¹Äž=©mÅäÆg·G¦¼©§FÁ|þ6H¼ÄjמÛgrÒå@¿Vü8ýyä=Ò·8ÛÈa&…ÿÜ0)ä×ÊœRDŠÔG)´¾‡FN¶@¿¼2ÏÊÙóu»#Ðh-À$ÅF>_xc|Ò£ñ-lÖ<\·sW¹ChXj’‰…°6Ç•q¥–&¤2¾ö†¾ÖÉÍðH¶š ]Œ»¦T%ʆ‡»lLÉÓ‘ ­@¬»wœ¹æzA[Ù½Êg+ŠÈBø‹¸… ~nêLø{ƒ—UîäN91ÒÜâÂÎáÖkíÉ´æ*Ô.©]ÍIØïѦ!« ºŽ¬ Z+ ó »1šx™?§d^`QÞnIÓhëÛVÓ@ÑB<¡ÝJWç²–÷°¤FÜp°)8½Íàã0¶ð¾~J¸5à6f:¼k‚vÆŸ4I4 ˆc-È$›Cô­¡&Y­©Ÿ0¬|L4±#êiœ£IDkèbaKåݪ† ÝŸ à½O¸ÐY3 teÐ;\á÷ÍêÊ×Ð+VŸb Ï_Y\Ý-\L yrÀÚ/T#¨kd‡åhxî¹øûÈ3o¨À)áÇ{¾˜¾Vqd¦s>ZȃʸÔ&Þ¹øŽ†Žû`جˆàVn´Æ+ø¾‘S$k€GÓÊb¼dÊF#ÚQ:ÿUÚ#&ÈÞ÷5+€ž»þζPà¥l]1NÀ3´’ôŒÜ^ !ww¹¦†åZ^ÕP#Ô KîúÉäåÃcõ)óOlôTó%¤Õa&zß¿ 0¥x7Rƒ„?FL]X_˜Dsá$Ç{^MóØhŠÞóƒò(襆­hjK˜+Wß®‘ «È\ú}è¯Ojùñ ¢y FkJAmwß³e•.y‘zêry äÖGU™ir;øP»Åþˆž¯|Æã$/æú¼´t®Nð)ˆ\Œ‡û— £À05H™aõKºÀ™L`Ãizóyùpe²)ÚJ`üV×i䬘´‰¹ÃÉàÁŸÜ²–ð¿¥ .ÓødJ.PI[á—:JÅ*ñ-|EW»&=&ºŠÑ:qÊÈì^@O+öy®@“̼)‰ª7Ðç¾DÕàž þ‚D^‡Ã™À6#¿>OçidÚ›òDŽʼnEµkú•s v¿ÍòÑ ¡Ÿj›þUP-emØ5Øå«…Pt¢9w"ì†|ÕîESó`“ò8Úÿ—Nù…EE¸²Ùù¡ÿ0/›ÔáÕ2°×XG£ß4-þ]_쵩ªÈ%íõøì[?à­Eçˆô2œ28úy»+gê:ùÏÀ"<2¿ÜšIhÄå¶±2ÀŸ`½õ8ª ¦¥6&k„BZ– òšFåV3§:Ǿ±Šã…‚²âûñˆ°C©<æõçy§B Ù…œõ.Tµý™œ‰÷.ªÂewݳ_ìÊ­3‘þèa\̼T+›sÛ|™ÿ>¹\ÛïÖïxŽ˜Ò¨tv—óõ ÓBô3N‡Žñ]x|vêÀ ‹â˜ÂÂÈJIPǪîkÍfß”ÅäZsdã_n¼?¥°ÀD·Û/¿4›@ÎjÙ}B‚3S«\k ’B[Q¶¬R{ «4wÌÛÑ‹‰Ï¼!góƒâCÛ0ç±v‹ÓK¶ IZzû]™éò†:Õ‰ BíoÖ¹°¿Ó‰öþMpI‹wÔÐ`‘ý˜3уæ²_‘Y¡˜×IBanI >mblzw Gѽy]'ÅË¥¿ÑŸúÄïÜ"§t Y[Ÿ]A+Ÿ‡´Ý(œ2(@«£eõc`nwªÊÚÀð)8°}GÎmOåvjÒØnê~/Æ$}¥l0â®uè‘I–œn¨Xq¥Â¶gì&ÉR¸îÉF¥© C”Bµ `M^Åuq˜wqˆup‡ò‘ ûkq §SÚíØK’Ú¾ŸÑ,"?H`Ÿ0ª—᎕V{fy²'娲T&¿æl®òªi©ÇeEü|ø$"Dö¸u)Cdcc¤8°gcP»-²»ŒÓ]|Оí-ii’ÒËÈ”ûøb£•úœK™«—©àãÂÒÿüFA»Ú‰…êd$%{¾ë6·µ<ª´%º"žfívhK<ÏÁÿP÷Œ†ãõù,©¾L$Dž-ñX¥2£r~?g·P·ŽIß–r ÎKmRóSÖC3¿H…9·Q[<µ±©^3+Tö§§5éLy\É‘pôͱað7ìôäçvyÈÂ¦Ï ä hšOêYÓFpt(n¼¦ßrpyŽ2>O·=c!/(Ö—R×ä MaÕO8ppMt‰“0¼º`hâ2£k,PÞû-=cëDó¥n‘OÓ¥pfM^vBâ¯Â2ùPô÷¾zu‚HaCo®=öµví&aÊpµS^yì4RV D%/D;¶½4( æøÄjç›á% ЋB׎G„mŽ[ÁžÞ4Ó§€í—ŽÃ¥Êirj_ìʇW¢pGÅmªÚbeõòr»hùnÀhŽ@Xçl(q^òÝÈŠ^è1P¸‚E®’i÷XÜ( ,äÛ„£Å·fd fÜò¿³CR*î1OËÑ`L¦ÊSLïiÑžºÔ§ÄÅ)ѵŽùÈ­ÃfŒQPÈe@oúÑiBN¾êŸ:Îûx†R“}ÇFae€²["ƒF® ä"ñ´†#¯DäB‚Ð%pÀù3ƒçKˆ*ÇÊÞ)¼™ëuYÓ=Zkf•n½e‘Ì@ùg𥬄ʯcÈÆö#"Zöð®kGâbW«¡e€Ãhâ»ùt!µá݉{Í$ßuŽ|fÙj1×].C[Ps_|BRŠ[iÁßUaáû÷ƒ®Ì¾ÇÚ²—Á.Ÿ êa½ò柡CF;aT'ÅTž§ã,T*Ì'p‚2P­i}—g°îcÅòä 9%úôõƒLz)\ì\Þ9ç®4¡ÑÅ\N £€SJ~nÜHWšòçCR¾*ªÜDëHSó]ž S1,ÍjšjLkoÞb½òxC_È¿÷9Û~pMuÇΣ4¦Z*Þ`Œs”ìK¹†:Ât}}çõ„™\ö‚Z¶×W"%Ó~]ö½^çŠÞ§3Z„Æ Ž¥VK"I—›9Ym m ½_ˆþ#Ù¿ßÊŒ¿B±­ís¢ñ”"0’”‡´ìì¶Öå‰ärA¾)Ë]#cöÈQÒûáA½1TCF¡âŸ¡“ !lÚnã”}SYm½y˜çÜ7XÛ=¦=†^lnW\͹H˜²&Ó g­§Jo› wvö@yìÄÂNZY]R³ù„³ð#mÿ2—ü©)”XL êamƒ)L¹ÂÔ@§Ñ¼O‹vÐÍ&¡º œYaB!A¿DÅ^Œ€šðdè䮿NIÄoàJFE¼’U´M~ÞøËcz0ËÏ$­ÕP‡nCûä2*z^„P†ZDØֳ¼Ù꿮؀Ú}Vh,'·mä_#¦¿A©NT(…XÈžV&Ï{qe®z“‡N5”•O§Ð½).½äp7PŸ)ñöjÁ6Èè³_cZsWe F]3ð9étîëjŒ–ä Al7¥P2ívÍ%0a{jÙêô¨&ú›þ®Ù“êÕµ˜Í„uœ'œ±­LorJ¬3Qør*|‡ì-V7K”ðz(ê+ $¤c˜¥”Ĭ‚p[Ý>óe›?ZS0ßcÿßÄ}ïûˆ¡ìõð³)ó*Ü@;–€cÍEêÿd’ÕŠ-Ôø¾ÔÖŸxö1¥-ß…Û¦†×ñÉf—ýK:„µc×1Ã6½ÿ\XÍŸÉNw½ú hÃ~âr´ù™ÓÄ Í68ù¶2,®:ï#sgïJâÒ .êp•Ü*ò;¹…_¼{-ä·}í ‰·ç‹:)~óÐËOEG O[\Sjiñ_ÕEëèbé'Ë]9ÈâÉf¾áÁˆU!®ÑÒvÉOM„¯0˜­…3ÍhÌ·!-ɲPDü…Þ„AA*_R`i[hUÔ¸«©È÷Š‘wk±øŠ†y«ç^²zîx'§fpj ÁÅë "”Yœ>s­ëÛm!Q—éUÁÚµ?ýÜLò=¸ì}Ý^ÞšŽfÀZ;Ó¤‘ôp‹›>œªY¶ÅÀC#$ ¦zÉgP9ÉíSØ)K¬™òï'v4,»Ö/—í¨©ß(ÌN´JìÚõ¥›è•ÏùR£õTþz7Ú¼[pî8âºc6©³Bü:Ø;Ye˜Ú©JÍp‘è•>¿4K>™â¯G{ô !sXÿ*ÿ 0®I!Ǻ.­nH¥¢Ùõ.ŠË¬œ&ögûù¦ìr'˺iK€x·IÙ¯9_®Š¨Ïg2X"õN‚§°Y ±¾kS=h¸ <ÙæÉ¬Ò`OVN'£âÜékü"[ÒXc[õ§]~q:KË^ Ú3Z&õÍíf>-¼p,Ö¨¶Z3 ßWa6#‚fIm‘ &iø^°ñ6«r§¼@,}Võïdw­xm“fàšg¡¤Ç\ [ú?ŒNvÎ\:DQ°þæÙÅ8颇S6Z9w^Ä–ëµIÄu;ß÷I?* Q"òú=Ò¼½€%/x9Ć‘Ñ´¹å®o±ÐñQ—§›ŠR\0jIˆRþ=8ÏŸRî“Y×Àl\§k(·Þ­ÇÅòÎÆFp¬L]S YöÈÞøÿqÞ¿Uß?CïÕ›G»°ú…~ô‡ ³‘êÊšéI­?PÔ0É’”áû©E› I˜Ô<'1]’›¤¬)±fúrýÂË\jšÓ§~Ê?-6t™2ªw¾Ç­uéÊR°aùÄe#B«y/¿ºÄ¿_=ºœù¨Á§‰£~"$ä’縬`sFÀnSJFýÔØº‚°„8JH¥¦Mð¤ñm<ý¡0€ڳbå‘h»–Ìø?? ¹:mé;!wãÔr¤Nƒ#&@¹àkìªBietŒ îóD0â¹ï'Ø–¦dDi>Ö•ÏÎq‘oQžûFÓZ`˜!¼ü„säØèí)¦×-‚òïÄÀô¹ ø×ûfªn0;IøqC5nû0SÜÛ½Uuc×øòd*—³˜ö‰ƒ¯€iØHV¶¹Jr· zŠ<ÓôÖô(Â|öÚÇL(|懱ƒƒ ¯C—Ú_±Ï:ÿþ{¢ünJ¢ÍÕ\y…,õŸiGhï‘}fd’vöƒ”ORÔ›U8â©À ‡È wÑ`éC¹ðuÁh͘Ññ„6‹·Ü; Åtì [è r6]‡œzFý p:)÷‹a”ÿKà´‘ý<µV&;ስ"ûùÁG=&kvÒuJˆd¹èºgèA& ãDÅñCÃ)oPØl}PÇîÅÄ78='¤‡€2qèMª¾­¢ &¥öá×*fá)†æ>0úžm‚Ñ3÷Hݶbß Fú«—ˆÓ…}H<“~¥y•œËw—ǽëyŒn`Óö˜¡–0ÜëOBòœŽþ¨;5¹øEéqnX͵jW 6ñ$‘f¾iñR, +µÏl`R{æ5QÅ(§93u‹Û¯ukJ]gRÏí÷¶¶V?9ôX^.\¤†‘œlɰ,.üOpW‰L]fI¤r°@|JÈÊ$8 “aáI¾à÷hä^IìÑ:+ªM½Ä@ãì ~é£QîÖšëdÎ3Â,RÃùF?iíME½,u3³3 QùeÛzAò{]Ž÷2§)£Wì¬sFÆpâ\mM±J>ÀL‡âv T1‘beY€B ^¡ÿGûƒ¢)ï€Üæë¿!ÓLnˆ<0‘Û%ûXu¨¨¾’¨‡P, iŽÓÞ"Bìÿu™„Ê¥úGßf}‹{OÊa‡õEYNN1íÓˆ9‚Æÿ!¹qùÎ-¬÷Õ``#; óg~c¥õ·ÿÌ.㮠ѵEeÞ‡†ºdí@qÝ:8/%]ÂUEãÄÍ¥ˆžXa%é^!öš:Ô½¥±ÂU¿ôhü ÐÏqí[͹޺IâùÙ?Ægò ‚ŒAÚÇ{[`!@aoº î… Â]%.Þ8µTÈ æƒ¾Kíÿ…u;¨ŒœqGƒ”FAôþM¹zËÒ l„€l[ ?Pª0HFçø „¬²’KÌS=.<|:„±©xÝ?ér\rQbÊxF^*qÅåÁº$27zfki¸=̓•1ªˆ@·@:WnVF¡?VÅì–&>M¸(@^Ѐx–ÓýƤO >¥|°þåÄë—R zöBÓ÷@˜;J-[ÉW·Â˜ÿ{w áH¤”¥×øâÌÉZ‰DÚGÏ¢ü{/$¿‘ñBá6gÔ¼åWF0y,XE b9…ûÚ Ñxœ;J­`P¼klô^®ä3FVg“ÑZÒ£„>”·¸Ø8˜à£á…g÷QÅë½½c)„°ì@§n$AÛ%ê 7D•Ÿ3ZšWÚ6U¨Ed¶Ûæ˜Ónå/È1"dðçj Ý$½­ò˜s4{Yò¿á,÷ÕÎåKÄܸ‘žÅŽ–íôަÞ´:}µ¥¡I¡°`a·UÜмùG™Ùé+Œ¥’²0RG,Vê|€ È>ñε{"¶£Íf¿Çï+DmÊ N¹…úˆ§ Ú»ùâ>Ø‹ôX8ÚÉ&<…A[„­õžvB«-¬TænÜûGx+ÆZ»´®LµYÀGÍ5®àÜÅ´%Å@“ÃJñÓ¸…nS¹¼«ü~°O8èx¶³°ÂñG œWí«ß¢»´o¹ù?»cï;fËV³ìŸšŒBµÔ–éÓ‰f“a _>u³P4£0ûÛ.7ÄÓàvŠíkªm9òAÑ\gnŒ±•5¨äûÚœÅ`Ž»Ì4ù<áí'ˆ2cǓƩi…ÉåÌ!l¾®Çîßkuô ÃB Xoºv³ËC2TºOHj¤9Àn¡‚ Ù˜ÕÝ´éèñ½Dÿ’y- [#)•¦?qÕ¬nnòÚ†t¨­{ð#+:†Ç¥Ë˜”-3ºfŠƒæ—ˆÖvx1ãìF¾­˜L?KE¯ÍbÏ8øˆ“¿Ç^:ç±ñ&ùùà%¬’×¹¯¡ô–?óGÛäHò¹°>•ú+ËAìßh“q ‡æt´2ÌI¾&&—!ÛD°ïpWëp›T¤ÒÁ¿%èêjÄ{x°¬Üw¶†0{¤éä'FïÍ.9Y ½GXÂç.Ìl«&jEÁ{Íz#õ¼jŽn+Ž8äÕ>ØT‚TM¼•{LKú#æ–¢©mY1Ðy¦û=Ã%ÿÂjÛ6Í||Ya›‡¶FÖ‚…ÛZUΜjÝhxJR¡è[Þ$rÁ^ž[…³Ý“~Zg㱟Ž{%:Dd÷Îl;¬dI1ܘ0à#ÅjæÖÂ2سôî:ƒ{4ÞbV\¥­¨ä¤ˆ /øšïð/™.éËÔWµ©©-\™Hã×÷À ŽƒÂ4æÎ|«q³­Úæt×j7Xй7Ù”ŠóÏ=•÷˜áK #B)±\þþêwÖeyø2ÛòPîñ!ÍÅÖãÈÈN–¥SV£‰l8Ý;„³´w ëMöÖ?õò;èP¯ã€‚ÖcQT!mw#ÕóãÜS4‘R­¨WêZ¢¬¬y '¹¿yîic»—Ù¤ô¿+F|M[JS¡Œ¹q¦#î¼`õéÕÛ_³Œ;<Æl§²YHˆ÷Lå<žµHEË’‚‘J²7Pº€Òö8$dùh”Þ4S)šPµØY9H;§§=í˜ä_^:žKë¶>¢¦z ° SÚì0±M9á3Å d:P¦,©ˆØÏ œ ž~€Qô­}ÿ0ѵ2U¿%_‰ ÄÒ)§žX¾å[¿FäCŠ3îâì¡5ìÍLûƒèû öÕÞ¨{c±éUù‘á{OÂ÷N$C¶™ËHèB<šÎq»wx9à%±ø29²ÎÆÂ\8z ý»àîÓQn2µ“&š>Ã#L»Æ•xU]œzÑ¡>Q¹ÓózO½†ù:©ì°‡o_7gÏa>~ºÑÎx’ùŒ±Éc±31ÌD!6£zxQ5ãPM®Ö>¬·‚±ºÿÎó¼!…€U ¹•ܵÖ/“]¤U«È™3òÝ ;ﺾ9IŒÝä´ã'÷^¿/Ä7J>$ÍÛw˜@¥Ê'e­ˆÕ<·@kx°¾/ξþÿW¿Pö(åÆämûÒþGO¢1èÄ&üVóÎä,Z8d·ŸLÚ–ÿºÉ1Ôòب$41Hlâ‰ÁÃÒH( Y,ä*"ž 1 ŸÛ»4º¼l[mô‡}%áÆÃ£bŽ"ö‰~ºÇ`µRÞxíÈ>qsN;#²œâv¿‰ ×F†v(‹¤šBΰÁM×gHê²pêòŠÂ+šó5“9–u ôòD]×V_}=Av'›6}zXÑ‚|›„Ç»¡€9ýûàµÚ„3ùØAýÃj5õ´l†€¼/9'+m%³F½˜~ê[” uéÏÏ ´F©šáÎŒ‚Õ¥ä¬4Ÿ.íì×à N=£¡·Zv•ÁIkßu$z®S3>?FÉo(‚®}aL$¥‚5ë“q¬Iyª„S§hƒšîâÚ‹w¹Øzt^í îAAì3@¸H˜ÉDÅ;ÊTy\ãgy+4ÕÒ}µEx.ƒ&“‰øç²ko·–ûiwE§f§âŸƒrb×ßÌØ_0—Å í×/%ÅYe@ ù!¶ ÒÁ$¦3¥ç„Ðâ ÅÕíßöHÅÏS\À½õ¢/Cê7æŸà)`¢(A ñŒth@l3.)~¿Q5s:ÔN°2‡fÜD ]‚¨1¨gòû> Ó²­GÁ-Î]D¯Êêh}wldYHˆuÓÛ$·™(û5ÿó”>ºün¾:cŸÁøµi€À.‰’Œ|]æ´ñ?y…ŸGÝþLx8LûïZ:4Ò O¿«XÅoÐ¥fkÞ½¢õL3ÌsD‰r«“¤þ  Œr‡§ÌË ŽCøpÕ¶°šê*bŒÌ€Ô(vÞÔ˜Ú-yLYt§çí T“šùPÖÍ!(#>€NtÍi3€Z7ÿ"MƒPT}r/Oɹ –ÓÛdvëù¤ÔDíîÓ3Z•м×I·À ú ãiR7ÍË’¾_ãª/ÐW;H¥F Ò=êê-‡A¬ e6àùDÇJı#M‰ì‰=[N8 VÄü·Cqû¹$§½Î@¡†üÿÚµ¨×7U’êCò-¼œC¦F™ºþ f9)„QDJ…Å‹¹ÖÂH¦*Ïžbi®þ⡃ŽgNñÄÛŒ™`Þ«þ'$#½ü5¡ Øè é€köº]Ë…âÄ`tì7¬A}PºÅóûÒ3øíôU´NS½UÏœæ"ÁÏÈg&äYwQ² ¦PVÜö;<hkH Gà½"sÖiÉý€Bý«ºÜ4©Æþåg8l·htÌŠ$‚´#Ø<Aìý-¯*¡ž5FDy&¼€ =e @öÊ46m}`}?¤ŸÌ¨Þö <[-Þ·ÒiܤJ()í+ßi¶ë¢ÊŠaîQw§é4tÏí¿DdÔÍÅòžÒÔ¹ýK:>s)ç )ÔÌIƒŸbðÂ3)ÎÒÝØèþæ›G)ÿÎÏ›>¤P¸û1˜±|t’îþPwÆ~0ºÄ´rîSèžJµ¨Q7w¦U¬p¾m¸zVˉ º^CÂ9™.Ûé¬LØÿþ%1—o}—øZ#Š’êb8ôÓ0ôª] ¾h¥©rJ1œí `qê×—nÂæa‘.}(us¸|‡,™7˜Vø!¹É&uVr×P}jŠ- jÁé¶Ÿ3½ó‚F²@Bw…»‚8ŽétÊw“ê(cŠ4ÀÌwÖ™ðu©çp¾Æ:”—³µ´9ØëYšiV5¬“¿AaŠ5 dŽík­²L)’ ZÕúÈràŽn‚¸¼wÔûÓçþÊ#ávÈ=zYõZg©±5eGÜN¨1⢾ýÎÛú{ Á@±¹Ç÷ÇAud©”3€AÅ©†E_ŽdØáWúJ,¼˜…yS¸Ä åÑëÏÚ&‰ë'¿¢£E.kÝÐò‡ëÓô$Al.ø|ÆÞ ËgÚ,ÂÑ8·× 303ù ª˜}¾=œÃ ©´ÀˆãÎþ+®Â­‘9óŽr+ºhÁéOÕ"ÿÈxH2˜0‡ná<‹GÔ j˜ 2PL†¼WZ"r~ À¢ó‡­ŠØl'}ËK¾—[µír 7–¦ Å¥à»æqæ¢&8ú3Zv55áÆ}dÊkÁS®GÈ~qðGF1”¾{Ø[Éô¬/¼ò¾õQ«ë…ÊÄâ<ɤðÜJÇFµ2jý°­K¬d¢Ô ¿ă"‘¹ ×̉V%Ís°p%# nø‹6ñ˜9ÈYØ Lç j¼Ä©Æbë®Lî¦b‘O„«½n¿³ôõ7_ ÄÑ6î>µ!8TÌû-{ÊPyì(õOpÞ½£§îMú”å&³Ò] ñ=ÝPºa’?Ú²y¼XôŽœLù>3˜ìëÿ%%‚y¨yØÂZ_ œzû ÎËQÔpÈô1Ïz¨Î-Ø#`KŠ›><{Á˜½í=$6!-üü†]L×H ä-åy·øBÝa@7Eµ˜»es>¢Zÿœ f‹]ƒæÍq¹]Y²ÚòãK5Ÿ#gY©Ûsgࢶ—H£OÄ~¤éÆÅ‚W|A~TMšZÕ"Ë>røç$@…à°¶ìû=–~O7‰*ýe7ê¿ç.˜/¤ë°.·¨ÙwT@mšº5`ðji‡z·mÛ'+0lÔÙÃ~&«%fçn{àˆ(.&¸­¼çÓ¾— e£ÏGÏ_„³b.%E‹%ppt-qq„ŠÂ»šñ«Ð™Ò-‘Rm¸î(ÝyJ9üÅÒ·‚‹Þxfu|шR¨^cˆöÚe6ð¼ /–EúKÊK3 d˜¾ËYnQÃ9e¦àù‹¡Šj^0dVHqU³¬®Ä:êÕàCr˜­õy|)­ÎF-t›ŠÚìÞc`Â-¯×ƒN%¦³Öj‚ÕÓÊǹƒO/CKæ§>¸cÈW6ß+®²úƒ7ï÷„$c’%n²Ôð$¡æé5±À¨hjðW܉¾ëXK•[$cÄ^•³Œ±Š´žAË”@ô26ò-±›aU×T²ûf\ž»PM×i£†”÷^±ZìÓÞ‘Û²Ù²L€ì ¥æV€ÙGŠsñ©ÿ»¢œ¶Ø‚]V1MÀZĵþqÛg:4#iÿzY‚©øäøÚD‚³d÷i–óuÁŽIJâžôÙœh¢³¢L ÛU.Ù þõM² Ç’¶Ð÷$HŒ1h|wRà·×‰oüëÃŽï6±<ý`Z{ D]¡„-Ô»â1i%hhòÔóîŒ_F“*öÞHzèâ Ús~(Ef'˜ùÅ[mÈ!¤dsÏšÛÁá1÷Ù{—ãMûþŒ7Ç–)W€ÝÔÙnÁÓ†zB|¾.‡-‚&”p%k–ƒ®¸[Wq ÔilÛÔÓ·ÍŽ?þxU?¿gâXc|…ÜÀ‰Ajø ´ ¡Åí¿@a<±º™v÷C²©èéÓ¨¤¬:wD’.؞˸ƒã£Ë‹|:@oÜ ¥2Î\>û—%`uf¾HäIò ¥ßªÓ:¨þ$ +3h”ÛÓ|ÅzpUñß"7Ò_šîöK#rì(&-ÔLwYÉ>l?'(ÕtîSAÆqÓ ñ¼â,>üù(‚ Ñ`7Ÿ5™~•HLÞ2ƒÄtÿ:¿ÕdAîäátžVë Gqó/óˆ’‚°Tú;Þ]Û£ÊÀ—RJFõ 4²ÿOmT_Ìé\~{ÃB!a·®I<@N8 ÚK­8;û óþ#9ß?ðý?'rßSfME:ñæª ¢OχÅo•¨&RH/=\ëÕ Jã”б2þ7ñ‡êNÚ@'¾¤m÷BzÚ  Þ^„H”êÈÍ®Ü\ò9Ÿî¾óÂ^ê“^ôÕQš[.ï~Ü­¿ˆeÿ_ø²I›ÆéîD¨Ïzü +!Æ'*àÇ1Ž Ýß¾G€FÓ1-ÊB¦ .\o›‘†\Fø!ÅÞO²½œü?rX4ip°ƒIH=NúÅD½ânMfg&;™»‹*x7VÅÿ>Çý(u5¢åƒHy¶Jseí XûK)'‡Œ‡Kq'°‹ uŠ(#]åII³ëxd¾ëᘕk˜‘˜³>ÖðuÆI`àO·â„£"> N`0õ1ñ‘´¿Í¨{dæÛ„\ ¿Éo<çÈjÖ¯tnpKõùVÚ×¾&¢ ¢x5 J,ü¨Y”nÅ™(©t>¸G.®õ‡_ýT¢À6%G= Ì½³ê=‹ž%GÒÝIò¶Ñàý_´´ TRe íK/dåYý?3ɯ©]ªèþ­ÿç$SK)”ÍöÒ,l®{D\zþ£ÜÕYQŠü¤Aón -3Ï Ö>Šm5“Z‡C´Ñ‹³VB¾´¸ÌÑr¯Yó"&¾>ï‚¡°Íô¦-=^wcF6¹‡ /8@±†Ô8°dâím¿F††„§¬e÷z|àZèʰ…X3ëÙ_öKr Ý®|Ðìö% 55³þ°ŽÍ¥nvU1´RV\ñžî7X2Vw©y&¶Î,Ö 9+Vð»ù<{ÖÜIÝsZ ^ñýìÇhš›ð¶?2(Õ4œ“’"ä—Uù3 !ÇtSP‹›dÒÈš5 [Š?ÒQZ¤mècþ&©Ø_ù(Á Æs7¥r.ɦ5€äìèLí]Gp{Ñÿ°üG¬09:í|޳àLšŒ)öhãé´H§‹Ü7I2ÆøZ›ši¢ÓËÆŸ¸È­8%)¶‡ÚË5ú ™gÙÎ\´{I{ÐÜ¿ÊC”êxÉ #™êì" šçxßpk9Cpœ]ÌÜ€8`¬•Ê,Hò{+mq™á…ì¹<ƒ¡•SA¥žMb²"–³‰õ`Ù´![ã%—Ðë0kì=Âúþv‡Žk&^d³|à C`-H±H±”T…ì¦;’¡~JW–rcóR‡Ø˜ÂWyI©÷ýëæÖ —¡.m2;PDÉž¬ŸðˆFöKÞdmO›D)wÅZv! PÃJpǬ…©PÚÁçvÑ´Q©ZÇ÷,Xe6Õ*‡<Êœë «R\/=Ò(6‰Kßz ÷òN A;&¢“ÕlzÒÏðBÛEÔ¿%Gç ¾þ»=z+¥%"ü üSsI"Ù»K­‡‰/0]PÕxxYtcûoj–LÐóEÄd'Kö(ÛŽD‡u< Àd¯:˜á†cõtCOõâ3*¹*hV¬ BÓ>Ô‘Öšã™7‡Ë^؇ 0 ø$¤1®ødħº(¯}©¯S·,Rœh!ƒ¢u´¥ðŠ=™îº]ñ#Ë#%ø")A”{ËT¾žÃy,T÷C§jZ×r§»Ìh& 4ËT½ sô8»…„jüAÍÍkžqÔ²ßÚ*³\^·8ƒ³ÔáݯղŒÜÇ’ÍTÎÇ/#Œ£e&ÏGX¬ "¨À æ”Âò¯C¥ÈtŽÏ®Ð!‡–&»³¥<ZÇ4†AØöGý âÌÍÄÕáî)O>9Fõ4¯·çތ׮-(«ëÒ6{`ø8•R¢ÊT$$¶ïÂ’ÄW®¬Wšë±n¡âŠk£8êÖ^wI—ÍÿgÝ7}ÏK@­þM:Co”œ:Œ¨¹§2¢„ÒÂF–§ŒÇR~úôT)}Í«øóª|~n1` ¯‚#nàßÑa,‰ÒÛ¸jO`®OZÛ.ÖGµLÞ‹ó[““óz‘‰¼)t1·7ÃÆ’Õ7¥¾¶ÍOý½•‡‰?cT’áM‹”n7P hl~€ç¢ªÄs¢Ó™òYÀìÔçï]òÓË’˜o%;å+WÕ%^5M§h¹Î8ôôÛuYïïùpôf¸eôçâÃÎØ8zív2 ÂVþæ›­IMÛ³Ó²³~VðW¢B“`‰¾ï‚Kù‡¾]HÏçâ ‚56†ž!Cº²/æFºEÖñXn¬]±a”v‡àrގ‡ei8_Çf"&ÿH&ýZ/ƒ½«õó^úî%*_ŠùrÜbˆäÉH±R ­Ÿ†D‚wèžÌn4O$& ï7°š¬Bâ6“<þÈžš&‘€e|åH8Ò´A°D{éÿ‡jr ‹žî±¯òˆ ‘Pmûl<.A•4Œ,}ì’KŠ?%®0Ëž“Ž­ÞQÓþ[Ë“˜k©}Ð_YrÔ/µg ,É<.)=^F§ÛÒIœ=4WK«›=!€¡bxªz+°Ð(W²©—ôyL5B]jI ;p1Æš²WཊóY=y·lË£>WÀLwE£µ0¥w¶uÔËQ³ø_YdžRâÓ¬n•æh´tÿ€z™†±yçUßä³Ý%¿}±œÙ¨ÇÖ§‡å;|¢¾={ˆ @Ž9w‹’$]§ŸÎyÆbû…™®¶àX·)3lÔ;W¨d ;ZkãÆÄ¶-#J6m•40~T;“&¬²³àŽf}^“Ô~Š1üR¨ß^ o§¢ÜÄ í†n§îq9 @Ýî6u²m»…ëáú³ŒƒÁU‹&’!·OÐçÙ´‡_UCŸNÃ~žˆ8ʆEv•JÝ¿4}Ÿw &ô\6*´á ÂÞYž†;¹Ë\ÇGgÜǽîÎVu´WæÎ%’TÈÏs¥âE£y?±"ÆF]ñuÖìJŠ,MVzè_˜¹­ãoruGß)=‹'È@½7ì°øT ¥#BìViþŽÎxAG< =¸GvnêU “œnã °XÕÏTó#ß I…‘††?Æ_®?Û_Ë'7¹ÎÍIÑ7‰šL”É-ê·u¾y% fÏ,ŒÑƈöÍË3’›²ùYQXH"6ƒó)ÍUˆØ^K\Â8 {kIìÑ´3½Ùfî€VÛ¯#Š­J¦•™Š­ùQV~`µÜø0³~Râœsé‘\Sðä¸Â™…>xÖ ®çÏw½.|…EæêÃ«ç šµ|Q@ØT¯Ã[+zG¾LXf k‚CÞ€ý¨ú¬9 ÖØ8ÿÔ ŠÍÈM=D%Û–„Ÿ…OÞ]C’TæfM7ÒA—™ ûšz±Á¨äÆÆ›@|ã'ÅpÃm ³Ø•ãÐêí—ôgEoO¤Å«ÊÑ–å bÁ·“Œf=H¹:}fñŽ¿`¾'÷¹Äq]ÈíN,®§Ÿ³œcÖ#«¬„þAˆ„Í­Ú×™ÅNHüòòZDÈMÁ!®P‘»™ÁPv5 ±:V¥7?#ÍIq}¸À5ÆÙÄäbÃ]TtKï;§fŸê½²išKGÌɇ–X ‚p_9(ƒ8söbSöra|F[¹ÿÅ0Ô?p,8>aéÖÄ¢K{ÿ_J‹®´=¨ø|þ¬ÎÁöEEŽI=ç 볜ä+mý’§tKŸ S4û£×$4É&«œ@¹ªÓîŸ9{?Ig-d…Af@A‘à; ä?_»ªð âIe‚A)Ât”ñ? «–ÝB’(ÍçþP,‹Û›j7_)¼¾Ê¨" Rö>©ÙÜiPÔ7h&o£ ´?¼ÉЙži Å%LlÏç Y ö¤ïìÖÖ'\:ßépk$Äj0kš0>ð$¯;7tˆñ7'›Ëö!$}Sƒ|AN¹c>d]¿ÃÍîyõ‘ <º±Ì:z'2±¡žI@Ríºü¬æGÅê¨,ÞÑhÍÈ=Èc™¹<Š™ÄýSvvöR¦™Än3H® ª©½¸ÄMãòNÕ¯²¯Œ'ˆÕH>îIn¢ß˜_Q×ᦂÆ8v­&uÓUŠÜ徭"¾È¥ƒK½ÿÓäíéÒÄuús}= A Hï[ã 1òdL•ÊeØ%T1/×¼4¬î«Êœ°³ ªÊ‹Ðì#æ$¦ckÎÝûÏÕ¶îI¸›¦Í­L@’‚ î&äÀäc[gl ®w"mãìb%1mÒ©}}T”M[¼ôœ®lHåäKs—|L˜mPŒ~2`šiŽ.¢¯«eˆÔ¸i?ÌU’ê¤SxNlh‰DÐDpkcìE êwÉJåì%­lé̤VMƒ%¥{t*K_‰F›+mIÎ5ofU¼?s/ü!qç³þS2P²y€£‚"EÁ‰$I­ƒ3q²©.9H;œ‡z`ß×àÊPåÀÖù¬êžðÇ”=`FZô›H¬Zù9äOÌe}ZI”,ùÌ’'Ý£¿›âÜ2îwÖñU+×ÉD\Ë•äìAPP‡² åÓ"o'úy+¨+ŽÅ½ +¸ÁÛÓªÒnYŽ0eeq¹ <5ÈküŸ•…-¸E‚gÅàx¯Ê9¬v/Ðשñ/.„[Œ‚œ¤Å+ùÐÊMM*Þr—]!á½ÙŠ™éWÙ{ nÐÉu*Ú‰ƒ^iuÓBD=‰ú‰"Ûù`‡ì Fžajªµ`Ý~?’U{³>0Q*9«Õ‚Öˆª²™®J¹¯`¾‡ 8 ‚±gh„ûÙÕžÌø„,Ò­so¬dú†6Èý–v3¶ßgeͳ*ÒµŠ’m¬¥…ZyI蘒 ™_=)ö­È»ä?И¾Ì@‰)£wÕéÌO“SñÈ”áäÞ±ÙHPWïÎ8oŠuSOö' \­UA)$L¹88(Å–²ÉZ¨P†VºR¬(w=Ör Ë úªÎ£þ|ÌZçA)ç슻ÕµÒEð+¶40¹BÜí ]r •Ñœ) •ÙbC¢¨Á¦4ˆ§”P¶µŽ×“¤‰ôûÏ»ô±A˜ø‡'ŒD¤Eßµz”‰ž÷×±€êRDós%| ËÓÛrzðb×é=nÙÁæý€uLuU®Hg~íAaë‰çÞÛžô)U\Š xkUc¿;ˆrSÀ x³@H¸%÷È|Ÿ‹Mr}Rš·ÐØåM˜»t¡÷.ÇÙ¶Ë©ˆÈ ·ÇhW»4î„ìóD £¾!>ÓÀR€½¶w@X•R4`"³ùûµ'({æ>¶=2ömä¦XuŒ! ‰Bð¹¹ô¡1¡¸”Z„²Jt^$š³Ó34/³œ=¦on¸U’Õ–Mß~s«ð9 zq²—ø°ÏŽ͇Ւ¥2 ¡—HUsÖ‚›Ä]{TQz ¡Í7 ­ÕY»‰'®¦"Ÿ ö\a 5DÛFÁÌå þ_€tŸúœ9‹ökÆ`‘m3&²í'PÜJÆ©5.žªqkT\çÒ'ˆk ó0êXtÉ–¦ÿ'ú½à†ê4Û§Âb©ç@8µûx´!g‹¾.ƒ+œŽÙ UýüïÚÊ6ƒzƒXàíXÕ$hr’D Ä6g®d˜`~ø'‡ð:YÒØé _^œ:rÐëèÍôP7ÙÉ·Y”Îlzž¨}ðÿÖ©ã¶FêzÿÈtk jµÇëÍ¥óü•¡¨B)bÕâcÍȯ ^Ob78k3¦¨–¥>×”½ªd,>oèÁêö¾M>ãjîf&]¿UòÅüª8?†ß!@õ‚5=Ñe4¸sÇÊóõÕËüaëZ©ê%k\‘m¿¡µ¬¹U"§z’˜¡V¶y¡šˆ±nÃÊ<¤”'&§N£ÕS²§…Ým]÷A–¶ó ųïdÈÌ3¾íL>pHpõFh¸2.%¡¶øwRÇY…€ SèêOŸ6?Š®ˆ\÷°P}ó †^ùxS+Qn›ƒøgùJ ­î]uðÆÐÁⳄÎó;òAØ‘»>ê7ÈÖÚýÞ eâW» »ÁÂ#5©\‚ tϘrè.lÿu¯–nð ½eµ·D€¾¢ïg[pŠ2t¯‘Öìgb‚»}žÐ‚Ýx8¥ßo¬²¦n€OÔ—‡#nÛÄNfoP­½üT9(RÖlorÃTie˜¿”e‘‚‰³›š B2NÉþ¯ŸzyJ`"p!­ØµoJÓ0Ì—‘Vá˶fecyXÞqçéŨ·É‹žwQ.ùOÃ/øÚ«r$¼áG¦Q¾²ƒ†íÚš zÙ;[€3uÛN¤6ýT~Ârª#, €½´ð§ Ž,I‚AªCóYo×]ÃOƒî© 5õ~ž{l'æ!¿$µß[»¶' í|öÝúÌïT;vÈñ$èî˜ ¸Z±ož4BÑ4h½é¥=øKYÍ„/Äy^¶Uƒe àšdk󱫅éüÙê$sw¢+a^â6t‹Չ̯®J>E` Gg)­ÇmdI9´3ÕÄÍ£LV汚ã†Íˆ s1 ^ë Äލ°&œzÄ>w„Іs°Û‰Ö–ÒOñ?f0C4Jµçrس'µô´§@kçÛ\´XJ’˧á²hjæíHiv!ÍÞ_¡¤a „ú«=/LjմxÖœ²NbXCC•.côÂ6¤ Ú×OòXXÆ­W¥s8»lqTœÍbÔÆÓÈ{NíËSì"AŒ ®¿C„>†Ü§Ò7gä?½ù1ßëoXSq@}ƒZ[§_©.vÀMA>TXÁ€‹&Œ‡ © '!fè.‚¬ñ’»Yd;ÿq71¥ÊÓø1<Üãþ%O(Is¿˜¿!1ãk?½Zá´Ê«1(è'¯¯|kdÿô|hñÜ™A#Æ”‚°Vï²8§JHLŽT‚ÇøÄ¿:4Õ}t°’#¦þSUʪ,ÛÈü¸..ZGG2ÅŒ«b²1$R(i1Ì!Ž*ëgdžñeg™¸å—j*W+ Ž}st€ ¹‹&ÆìO‘<ŠõâH©Ö`N(n£ †qæè´{‚ìí%m~Yq: œˆWs¡†½íì·¡—÷ŸwÓˆÅFæõúŒ””àXl °ôÕÄ¿ÆðnA $Ý\L‰á¬/Y~ñ¸ßí·û!Ÿb<µõ¢B“à£dÅûÌøÕŠZÆ4%ST›„´rmÖ›P2*Äð^+$AŸ2ù[f¾)€Ëb."}wg¾–M¸U•^½µäß«-/62~£ò·¹po|ÅÔI?váhmyÝþUø‚ÃR/™K—›uaê]\0¤m† Ð1ü»ÐþígÜ:½ªt']vI£ÉxÀ½òúªÉ䌽æÂ÷HuUåÊB‹–Fº]ÎfCϘLéB™“³¼Æ =›B#ÄE“Ã4ØÉU£oÞ¿àòðEk®Ä¢ðóµ®¼­¾À‘šwùEˆ6’"y1œ ްaO î¶-8ùXûRý)UGúûŒI•Ù€£r¾ÄYjKHö0sˆ9ÜÄý…\€~éäï#D‡Ö™€ÔF7¡(S-Ì’²>¸[E 9~±DµSÃó”l"Jîô~+Å:ݾ×ÈcÄ+ýñ­\N‹ëw"áë—€œXq­j1nLu'kËå "I]Ôj™ç@YLDðs'++:æ·,‰]€3yüç ³‰æR»Ë×–ò°;.«¥òÑýÛðÒÝ«§xL¼ŽË‡¦Yÿä€Rý ««£ ¹pÀ†¢Màj?1 €)øûÁ¡Žcðø€9ñÖÌî˜ð>ë¡Pb‹{wÝ9‚ŠƒÑ)²bÌeóu#è¬ Ž{D/}ý7}c!·¤Âß´ÂáEŠÑæraŠsËû³ Þ{ðïÆZ‰¬ùÝÎhû`ZìËè¸ÕékÛ¿lÎÅWÑÓö –æçÐàÉðµå9²6u+Vg™oL€õpªéÏËD8iå/#ÖÕ˜Þ‚dÖ^s×S'àpDêô†»:êùW“Èr°ofÀ̯iÄŒ‡iÅ〚>õŒí‡Tf¤·ˆŸÕXRõ÷CSªsrÚÚÀM»½e<ûîgSí·þì8‘Ê#erú¿$âH˜ÈSìúTŸ™â—¿ücQBO”Ýâo¤â(ëèM‘ÐÎoömêaÚvý»ŸBQå®’·Ë%S ^¸ ï¢<wk?ç(Mß¡s\'edç/×Gq²K–"$®nËr5tžrQ!:½$n¯ÛÖë¾È‰ZHÂîTN3-9ÁÜbúô(í´Œ!G»ÄßvµâLoÉ.IЈ‰êj ¹é14 NÉ«ÃÈyãàCaÇI(D¢UHx)ñU‰¿ßL¿Òa®û`н G|ÑÔε׈Q :]´~"œ”^áwq£·äèþx4.2²á¸žÝ‚ÏŽŸËñMímmö{¯my>®".j,àŠ'CðÓ“e6ò‘ô0w/­ØVéc.—YíïOìôÖa„®ß`W¨ëÏÁ\n&_â+!¥ ´òfsQ<‡•@ÖÔ”‰?ço|3B$w™Ú¤g´|áp±éª U$GdD¥qåzÙ£)“û„Î<7”é9]·ÃúCûr 5_ØàyüÎ#`.þ7 „õv#‹‚–¢[PÆÙWrK_ÿ$s0¶%ùãJTÛ“k¸'¶ËMw×iPTK Â'Wr{Q÷Ñÿ'ȃ¶Tcµ2ð³Ù&Q;II-”eɯ¬[ôvð®ªn¹;ºñd4™èáêçc¨§M#~Ýè0›-Ùææ« _4 !ц*qˆ cC1)›aµuÏœ¡Q‰ë˜^öd¥7vÑfæàXHyO©ÑÊOa4V1–›ï¦ûzÈpNne•N¦£#Z}:–ä?ÆqN'7;pkxÏFs}"‘°VÏðßþ÷RÜ{0Óms«ó¶S檤”òÌVÜ÷¿u˜-È© 8Hþ!sì ÄÓ‘”0'5qïC÷W’Ÿ[’NÐ+ôÓʹ—ÜÛïÂD6Åþì$–U)Ñ¢ Ýµ°µ@¬^‘bÞ)À6do´™x5,*#‹õ¨'†ã‘OÚC:£q7²-;ÇЭ°KÂE¾YÕCñï·õqbç)nÑŒm«*ÔñØ(ÑUUÏ«¼±¯þÄÑlëÿ7'(2aí8ëF°ì'sQL”ŽÎf»øºÝ€¡.ù iªmº!~{–H^?ânul¹},‚fÒˤÌÖ ŒzlÄ—ßÖ’ âÌ ‘/X;´QÓg§aH— œž·ÚÆ ¼-©!FM[Kmp6uÃp}q‰~·|V¿}8²ŽÈÑß7A†nzuã‡ÑëkJHÃ9ó‹0SÓ)Ú§O"uüÎ@2å d†¨xì˜=ä0)¨ÇƱ²Ü÷çòX¨gQ7Ô2yi€Dƒðs#¾c‹G8!@{K¿g,~Ñ{í²NàÅ8™ºš<êì¸d`Ú6ÇðÓÝÞÌBÛ“.+W\_úÅ)OÝöKs¿g45ä·¹¶hÍM˜à“ÈÙJóx¯"š …ë’þv˜9®c«ÏÀy†œ•“VusUV×<½/i*˜Ñ:2:èÓ„d¶È'|5„ˆ«”Q¾×ÿc™ã7‡xàö£Ewáã7xvñ™Øylïe¼NL?žP“éĘ“L‘´E¢Œ4°/}$FIÑPØÛó%(gïEÜÍÖúó›n!BŽá.4=@ 5Ëë‘e¹” X½2Àž\ÓÑ-«TrÝr¥ÀO¹j´iƒ,r*6rÿíqªu÷½àéõ,[ÅÄHÏñaBMAÿŸ÷WîÌ{šÆ¿—Þb+hg…5JŽ’ÅŒ¨ðÂü¬«ÈYç½Ý»À£w2}W›oøB<ÌÒ8rd2@ó.-æ}^WiLó³zA “¥(Å{»bß½v¸[)9ÐÐuº µiaDv¢ãÃo$9l­**ôD__‹í,oIº $Ö².(Ú"qJïÅôHdv˜ÑoNOWÛ{ òÁév²O–.Ô;B¡¹/æïz_y¨i8‹üF³>MÖH {L–¢J4IÿmÕ}™Ù,úåþ†‘™ óôçsCÀ¦ÍÙÑ~Z=AŸw„Áoæðá—× u`)󇙢X/—“c3Ñ‰Ì €žîÑDRQe=ùêJ¡½SœÒ£w3ìaÜ8Íd”ø­¸¨¿´£Ì¢L ¯kà?*ºzŸ·›dõ³Â¢ÔðcEwq“IN«ºúâ)Ó½Xz%‡†Ž;ΘÓ%§pÇBuãHáø¢%îñˆ"R´1äóU—‡©å¹ây8¹áxeS…hFä:Õ×tê4:Xn¶k þqlóÕÜùÀS íô¢=òà #…zM=šý8VXpÙû’/önôVG÷h´%Ÿ Ž1¹±ßs†-±Nî,ÿ.öla'phFÍ;8H9nR~ZY¬Îæ´ÇÔ $æwòÁ™.îÄ<ջNJ_¸ÔI„É@©‹N>/­ÇYÅš°^s×C–m_u´™jûêòß½¯in¹kÁ>Ó² —UD:ƒr:|f«âÜoŠ ‘òSÞ‚Ãp©Óö¢óhÌ(¬%ìé”=~ÏæH*9Ev†âÿ25Z¼_Ç¢ïTiŽò”‚VÖ‡\W¥õŒrÚO„ÕìÝy3…ÿ‹~ôº®§Õ»¥"ö÷ -ú§@Œ£ßŽ9˸“[µd‹å 'œ×ˆéy)òÈ1eá5¾ŸZª$h1T?Np qòëèB±ßâdš¤Í:Ì ù•·®‰@J ÿIÆØçlùrU2õM{äÌæš%(_C©OÿîaÓãwœ}V\!1ý<±#Û“­öÇôî"ù£Œù‚ƒûÄÅ«´«ù÷·‹7#äüù6è s]^_Þ†Û«9±ÕµSpÚ0‡Š€s/| ª« ‘€™øûWª×¥¤"aø_¶þhžÂ¨ˆ¬ÉÈŠªôÌ\‚¯s0еòJ>ÒK¼hS'Øå*­ñ$^dBY3w8†-ËËùas%%–« ?l´Ð94|¥/^,ôƒ=Ö  êȼŠ×³Xhý¸» E)—ùZorGærU«ë´IÜ#Á9¾ÃN­óG2“Ú¯ÂÿD…YL±ˆ¿Ý?³”‰)Ž~“oë?Äx/\ïh“z­*OÛСŠé[Ö©‡j~¼4DŽÀ(R½ë§{ÓÓ:8–ü,¶ÛÏ,„®/ЬŽöúÆÊG…€_œfç“\KA©²kЉGaõ`*I…¯0ÏG,RÕømmbÏ6a[3 z ×´h¯p{E¥X¨*²¯6 VV¦#| ê·L›~'‘ònÓ€Q¡Š(Ñaê°“[‹|{ìÈ2ßÊ>8ñ öL6…P);­D0{8¼ËSÿ|ñ¾S"t¢9%žz§0G0„7$ »ûk» Ùü€^¡m×6T ~5ï]¬‡‘8Ó\‡ñ¦ì¨ÚúTrËØYŽírvÕóž[å•Tº·œƘÌõiÏ¿ °EöÚš¶ ’>"’”P~l·E]åáâÅÕÛÎ|ê2ÅÄÄ{ .ÆŸ¬’RŠ#‰H}`ãkÉ%µáàA ,œ<~¤^ú@'«IÐ(ÚÂ6Ñkˆë½57×$Qƒ±ÕÇ`Ì[ë'}ÖŠlÎô÷8+ü4põò§²üó0 Gœ2ž°NÓ¯=Uÿ’:qp&ëac2BÆóGÁë ßO”’6 sCDðd¨"/s :Œ!O9-ˆ<¶Î?ʉvqcµ\–È›?ó)âC˜óQK} #,õ-6¢ ÞÁ¢ˆ0ŠÀÇÄm?äD õ*@cò«5œ’IHnŽHB“ßaUij'Ì »º«|.‘y.Œ_ñ¶Ii°èÍãÔEw„•ÃnZ{<Ư B~‡!!e2G<Ù¼ Y‘:¡ÜFìñ"® ™¤åI« i[_`[ë®ÂÆ•¹Á4Ÿè…”"ò…ø x¨@ú¤¦˜º/ùd·ûÊÑÊ# /r/‹/,()kMQNR—HêÏ ¤Ú‡ufÙÖ~Ñátì6­œºòo(Âð÷ÙŒ¸ßM%RT»¿¼÷ɼ3­¸’žô‰3lý׿ˆˆ:)íß±4ºª`,ñ/ÌúWã‚5ÁÿÀéÜ‚ªˆ31$#y®®Tf™¨&t"ñ åsOèòŽ+V ¹æô¿S ®@¿ˆ`vtã¡ïšŠýå K«ØÅx¢ÿtACÀ°1¥ažvs5š¥`ñÄög„*5<#ë[¡Fž}é}VÏ=J'‰ª³­Êq-ÎÊ>0¢ùФn¤õß­uÏŒ¸FRVAñ(üj õWÖ)Nîôè-´%ÿ­ÔI~\¤9^y™~ïm_Èdõ!†ë%*RyÎÃcÀ>ŠcPcæk%j$ô„¥ 2' 'ß/rH5bvûRâX‡ä%ýœ©®å¤Q£Q gEº~ᾌ&%㉺MÃP•×;›œKo®“²7MXëhcƒ(«3ã+U¡ƒë –ý=¾Ïbö²Óz™;òmU‰lIuK,|†`Ç©¹ZxK&wyTÉÉü6y*ô›¯¥®™;‰§‰ºMÛ1‹øŠ‡¸-ä¨?û¾c­(2Ç-‚oÆ—O2Úé¸u1 mƒÄi”ÂRé72å"XÍé\¸¨ãC `Ó[\Œè“ Ò¾ÌK0ÁM·º‹î{ïð,\üð€‰õ[,nOT”t:N/üt ª;ðïÒ<•+Xø¬J¢OÅ`aÀ IWÚ:§ClÓ wgÅI%/”¶ucëR)ÉøÊ×.è`±]é¹5Ôdø®ÁDÂÑ™òUNø(r}ÕÃ\d®¥UŒEWÂJä!æøÙžÊ3ÑŽó­u,Ê2;,£A´”åvLÜL°eéÆÇ¶±þˆÝ–Džk¬ÃgÌ7‰Ÿ~2wk™ˆfÜžT‹?¾þ2¥Àt å!@Ãõ2ØÃ>»Å‘|¼gKëÏö@TbÅmªg 3äôë‡wTȪ‰#þÑ€˜§?{¸ x†”or6“ÕüÜ>Fß)×…idˆ PeI§ðâý3}§êäÎDc:ÿ×ÑXË<ˆM¯ˆ×¤1œM,#÷¸°”¶ÈÙZ?C†iC;¦ èƒÕ­ȵé¢ÎÐF«ÚµÂç¬èµ:¿:¥7Z`ÄÀ·ÛјýôOšÍEü!]Ö æ«¯dzï‡ õî;‘Îvà[à÷¢än—(ïØ¸7f¿ÉÒáU:CÉ»Á$Eöa§¨2Ø~ÐR5àÀÿ˜²3Ä)¹5ÌþYA#ü5LGã ù6àÚˆJV‚b–Î,79¯~íÔ ÔÁíRüæNLÞw„Ú§9ù×ú}{ïVúvšžùœHˆÜ›xW¯þn’cwB•G ÞZv¹á°­½É–â%—½®î–Qb>–©øÊïÝxÂi õǸó¨,·Ì¡ŠZ"8*‰Þà!æ[Jú)#íˆÒ`A´héh<¿Ï55ÑÎÜÉ‘7½jNh4½éDý˜¼ÕÞtcÝ–òTúæX:o;³µ°z`“JHÅSÕ×]}r²döµÿ`%ò¤ˆþe)šNF62zA9+ýк¯îƒ5âö—6 åMk«éëmâRâg27%¯¾ª"Øõµî¤MòµbóZÞÑ1麅•T!–Ê@Ê}÷>­ºSˆE¨`é–lAÏš)›{Y‹/ƒÊ )ÄRkEM;Õr„ÚÝ“ä«DG~8<óÉRãtˆíÔ®9B%Ü͈l*ò,¨ösRù=?#oˆ°ä¯;ïL†€ú<É÷ˆ}:;©ä¸'Œš ð¶$z90]DjÒI1Aâ<á½÷¤¦’¹UÖj&lÓTó7þö:דWhEíI'þ°§%¡qlö+»VlÜ1Tþ4ÕƒiÆ-ô¨¶’°Ó„#fîl¿8è¡ÛÙ-Œ¬'™û»ÃﶘUøþ;£·aﵚ|òox+á˼çG–Râ8‚LÂ7ƒ÷\ÌtõÂ+\ˆÐl"I¼GITÎVF‡k0”»±SC$t àAMλè%ëíÊζ¥(€5 ̚ňI÷xÊ’‡‘É^lôí!YÑ„LXØR®°´_kŸÀÎã5±ÏO5‡òføÍ\^±,·`GŸ"ŽNX¶ “$èTa}à¿6<1Õ(ÑHµ£ >ŠŒo´Á…ÁPꩪ=ÖÑCbš7~$zp/nªIiž|m¤”ì~„žR£qòÂs}-ÈC0¼Ô…¶ï&¡ ‡³9”¿K1€ðCœÞï}Ëß+ÊßF}5]€*‘ŽÉeÖïÞÝ72qæïAxùõGÓ+ª(Á~|¨ƒw-¿toÜI6Z›E} }2ü#„ Åéˆ%áb¦å©cÃN“kJ½ƒ&BŒ–BPĨ’!á¸Uãm™æk©Óäd3Q`‚ZÐUÞ nH*`, ©`™Œh5ÔË#?:åÌo5ÊÅäS¿ZP•y<¨?›®ncê.Àlm æ,¬ó\fÁgÞ¸ÍnÍ?!*›¶î~61h•„“O€:Œ?N?UÑ…V*^š#©}·¦¨ôk<ãÞÐ¾Ä dös× rÇVD'«ßÐ$4\ãžfâ,»©ž³ª4¨Wg4ö˽¨Å¨ÃjƵԫ 0G|báyAHe—(-ĉr¦ PÈôVæPj“"òírϲÃñEWä5Š×‘ÿ u²=©„>œOÎÛí™Ý[ÍsgöúAí)Û3x…ÈÃè\ÛQ—;TÐüy$„§q<©f³›®EI¨Ò ™¬ºÜ~³D­§’wp TÃAe DI­ÂHÞ›HK‡Ä´ {Ñ«‚’ øvÜdqvÛÁ^)U PH¼ÎWRÙ#j+”TMc¸r%ÈÌ@ :| ½ªô†o6Ìk¿:^ØpÒ“'ö~‡*éúÊEß_{«Ù=yª¹ø3(Ôk1HèÀcƒÎöÃ?~Ži04¶î-ŽŽòsOBøØ?bKÞª«¯Ï=$‹ ø\Úy¯U_©àŠÞÈb‰|¢¯hóòÓ©wAl2eª€8ÜÃm™T<¼˜s6ÜÑÜ9Ð0¦ Xƒ87¶§Ô‰@{6Âÿ-œùP¥W˜íî§°¥£6˜ŽEpn\S[õO F-ìvOš½ízìBý ŒEÂSJª£Ð•z7t1©Ox81\Ä0a`·hÙ~nWÞËKŒXµjBïN® ©½‰p§Î§idB’S÷øÉQÝáÄ15EÀ?#ÃM„¢íä Ð$Irb£û“œ)ÜiظøìþñM¦3·‡ìå‹äÝçG´i–{åé#þrÂ!ªo˜ºf^;Óùîê#Û´8˜…æ÷vú]»q@&XGÙ;gÉà)Ah¸4¸ÿû$Á=íx7]nØ °(ÌúûxsxÎ@!È´É>wßË]qJÉl¬4µ=é=»>ˆ Þc½^‚ñæ>HÚj[„Åк]“äKIDCÿƒ/HUÉ—ªÉV*7jœ6“æI±’ǤH-¯_qpw;“ϧÂ{%É[dÂgù{Ö42åËܺ'·)mfõSîl(})ëêN ¯$Ûì]„[Zž€äOyšiߥʹ¢fr›KÞ¯ ˆØýø…0Û·v,Ã**@»H<ppÚæoDæ³± Q3ý¢ëÖò€cÈ zWÁ0ÖRDŸbÑLL”bŒ²uDéT$¶ pk|oÕÐwíߊ/Å<õR>bsöç÷st/Xq´5ã䫤Ǣùȯþn¦;Z"y{?¸Ó2iëÈrÔ†³eWeý†8áªdYr•ܺt²ê(ê³€¸r´#óöûj:=ýuÕÞåeBÁ°2ík¢.{D¯Ä¼~£S:ÉçbE“v‘¿«"a äœGž-㿃*vmì/Õ(Ü Ñ¾ŒÛ„ w£]p” UÀ/s¢?…]Óƒ×ìÖ»Fç:|ïü/ªÔ¶"jh»ôPª‘Òiµ«›*°9ö5+»\ ç«çVH3 ÌÉËÉ/Ú‹ìLZÀÔZ_i™ÏÐFª«)ÿ™dflþmW‡™3–R`Ù^Qñ¯~yx;!º%nŸña…<{¬ŸL«¤¥2to šÞÒ²2&I„}´ëÄfª`óC+Òk”ÇÄÉ&ç ¾ló¿—z¹Í2þç¢ÇjußéRO6fú;æÍ× 'c_«&µ†e6Á$Ö9¡˜L{²îL#bú3ÚlÂBßaöÕ Ð›cZŠËV<–¼@_ZÌc«r&g(ræ±SmømVºÔÎp+†³+êg™ív(Cúò9kçó×e¼€ñ[¾ú踥þþ[¤¨%Nt¸$Y“ÉÒ8ôô' 8Ç´hŒ˜”¶oW±Ålp;¯ð17Êã>8ÌÎ<¥– ÙÔ¯aÀmA–cÔ]5·œg?!€Äñß•œo"‘åb/õÄbÀQHºØî€ÃÝý… ΀éfï&ÍãÀU(å4µø„‚!ýV٤߂(Žèö Ð'áÒíÍäÿnK“M™qeêC ¾Ì‡jCTÐHÐbÀêä¢=‰mÀîRÆØ/õÉ|@êˆÕ…‹ši¼‘NAfC¡MøFh:hûTÈyZ·³ùº­ ™áRiB¥˜éÍEÊ%»•³·ží£¯…Ý)çóÖL&­[à,ŒÆu ¦¼!4Ì [N¯=ª0Ì7"ÝÊÚû;4ú‡ÎZn]̯;š&b$} Í‰Ò|™Íø_eõ›bWøXΗò×ì7ã,–™Ú×ß&4ò‚F"ŸVòE_”‡ _½?ïREº@©_ŠZ®r ”A=ˆS÷3ÕmÙ Ë<0lÍ•€ºî-c§>2J9ƒd é Z-—ÖÝ‘êšÝÄetUI1Mw>¦ÞhÆÇúk)‚*é‚EfôUþ´ýá8–¡ óéÉ!VE;7øeb³F|Õ¯ü 9f]H©xwµÂò c~!Æ6©CYy"Çõj_Æ«úÿt3¹Cà•|aùVÐì`Je8ï=ñWBdÃ2”>À¯£Îº‘Ý‚žwÖöž ¿dÕ‰÷€>hdâ–ñ'€2–Ó³Yèí¾7Á~¦.OÑ=Í8eãkZÀi7ɹÙÀÕP™wÑÆÉ‘Q»~|”i§ËCé9ÊÀÞZš£Wä´LuE`=xœÿV°Ÿ*”Wÿž›Ý‘†(rä&3´|8Ù9£žŠz˜Â±5`å;rO§mί|¶|z ®ß³ ïGöç»æ¯µ‚ÂÙ -†?|pþ\=ð1’ONâœO”ÜФ~yò9ÞÁ ÑCŠ-èÞcª73èߨ¬JkÁ9±Â÷?Öýž{{éîÆZ÷+Œ¡Êkç6ë#i`RœŽ]ööjž™Mz*Ÿ4|~»xIô4†ÌPq†_gØháëu*§;6)¸¼ ´GžÄª²~¶·nøV¨78ÞZ¹°gÉvŽ„_~Oºæjë#¤bIµ‘±ÄõÓ6È- ¥Ù’gU`ÛX¥º ÿ÷l±é§@ÈX¦˜ER¿Nóªc×úK턯0Î Ü99ÖM˜Ÿˆ×êÒ|è k” ²JG›.ôC®­%jü“µŒ˜í2ÍzµçoƒÓÈÒc‰OÑQX¹#|¡Þê°ÂRú#Rf`öõîqZF —ý“b h Ï¢“8wèŽ:Þ¦¥Ž{ˆ½@ˆþÇ„öÁ¯]¢H•9KøÁ/Y×…«’|(Ø?ŸÓ¨Þ¿‰ D4ÐÜΆ®o;u7Ч"ؘòž„?ñ8 ²ü^øB¥Úã­8£Û9-m>\à{¥qÖUø‘ú¾ï¯A­ºUºu%Xˆð–àš¢4‡4+ý¼æÃ5u÷.Å‚§’cl°º¬šsƒTm­·{?´{ ¬¼“S×8.5Ão÷eít=.$¦üsѱeSq¨zÅ2XlƨôĦ7°À"o¯Y„ïZ¢½Ûjžhñ³)CW=ØfÈÓ¨¦iì ³4£Ødg•ÿ9§ì³£Ñ«=/kÀÞ…YñP&wz‘C0©#Ѝ™]À€ù7!}ÅåðyÓŒ·õÇáT =Øå7aEð."KÐÍ=ÅŠS`Ï#ˆôÝr^qbüDÇk ‚1.PWP€ñ€ÍÆ1±?ç³l º.}*ÞSUÝÖžGPþA[Ã×䙟ÌdUûaœ3’ +„êÀC`…¤úT¬ÀÛj©'ÃÕ¸ôÁö|1V¡”ùw,ÌFC«^ìø~·’töe#Nÿ,ÿ8<'ϲ©SÒ;•§GáPæ¦Î 3í:¿É9o×®(ògêÀTLk¹²îòr¬zœóü„&ù¨}¦À OÆ´‹Ëß%0=«Ñ†1ãáHlQØfd=µŠ˜Í‹Ár º™¶mšh쇫“ 6*¼æ·RrÂge°«y.Ñbˆác¦¥†wqFßÁÔ5+ 5Â/Ô¸Š'lð¶|a A ¨ å`ÃLzP€*±Þn'žŽâiþóaŠ€±åŽI0…*„M™|NM3fÊ‹õ¡²Ð‰[VI*-ÁIË­ÍFQðOyý Åø4’«zÄÞÂrËðXú±wmçW˜È" E‡-ÝŒ*}þ¶ÊŒ¿HšDÓ°ìH(Ǻv„Œqw5ÙÍÐ*¥t•ŸŽ!gN ‰ÕÛ©Ñj¼³†Üå6z8ª¿›Y¾ÇÒ\ÂOšh_“ÆB—öë Õ:˜û„Ä5?M¼Ò@igÙþ ýžZrð"P jªæ?W€Àyš4 /e.nWûÁºx÷–Në€|×>Y&ȧòýöV¯Tå_ŸmɬŽßB×ì—„U:1Ædûð/7%û »ÎÂr¬;]E(—[±÷&¯d§é"ÔSâ_\`O¬ƒè*ÂfDkx–©•¡Êþûë‹üº²ws; nÜHCt ŒVÐSN¯qsqíf~å?·ÝÂÛdÕüŠÝcÆ…„‚ ÆÛJH,wc[ªÕ ì½Føð=ñ·ýŠ–µC ^JC-À¥ß°h±»ž†º½œ÷xmE°ÊGßê¬8RŽy>Þ „»'†JŒ½»†JƒrA´-™]fê®Bh†øµpâˆÿZì=¹)á5}ýð:Kª§¿âü½UV5h5 ˆ(–°þîŠðUÜ¥q ‘ÇÒè[ ™Ps“g9dÑô1¤8¿4 xI¾ºÚ}¢#îž?-ܘÏKML¤–/ý•ìüìQhWd¼NË7ÄâÁÅÅÛ *+ï¡Ác WÀ­‚MµzŒÉýwKfiðûÃèÅY×¶ó©X!üÐW,±¾]5# ü~™:/¤!`^ö!àÙq.YAÚ‘¯L®üå"ôFjÓMoÛÄN[8™ƒ£ ÝìM=8&aSá6 QÕˆ{»Þ‰µ˜·¾“HV^I#‰±‡,mF'%Ó½?‰oÓô²†Žnÿ¼Z[CŸF¼!Ã?8Ð¥‰-&Ë—ÄZî¥}Í,±Ã+×­-¦/Åê³Üúòï¥Æº˜øÃ k°œ0Y=ØíóHÇvÕ¿Hñtöu°ê~U OéNTbò8ŽJ¤…ëJ xFÙNÖ%4À†Ž¼|*»…0í÷%8òÂc°WÇ£yçwo¶ûûÛõךõ`ðÿ;ÝÐ8„¹û‰5JàÕj¶aÓP9ôÄÔí{¦Õp´OL¶` YüÕ·±a䉼ý'ð9*éïMvMÙÀ•ƹ‚˜•¸.þ47én ‚1aèöhvtà˜¬¿ÇC›Ri/c r^€q+øÅDs9„y1@QvÆ<Yä`ŽöU6o]ýž‘ˆŠÜ¨cïxƒû'”P>«Oû“…‹È®U€Ëóp‚€ø/£ž:!ï# °0¶»¨bnq•½)” ±GÍ^‹é•-rq‰àöG ÂyËj}ee,íþ¼-dŠ;q ÈÊÉ—cF wÔoØw9£Ú”›œÉ#÷6xzÏ]Ñaÿ¦Ï™——’-(ÝÚ ˆ5ãÊ RyŠ&7dmßÒî˜Hmž†8Æ2¿LaöÑlEãá£ïpú¦»âkñ€Ëý%Èù¬ü‡èêþ&’$@ÀÅZÜ™>ûö¡†E¼gœk$—n ê¹,gÅïä.>ì£|ðäªr°UΖò鋌K×<ö£§ChsnÕK…Ceó%âB© ¦ˆ@yxµóËÝ‚•Ñ>R1ð§Héu ØSÜFf—œ>¢¢Àtçuv3 Nœ3ŠÇYÅý2í“Ë#¿BCv åO}ƒ¼¡yw/]YíÜëyˆÒ6Ë0ÈÁõ3Qä —`×ÅÙëæþ ¦ôÍTv{‘7È—“3ˆþƘUõëi¥0Óñ”Y©©Gÿ“ <ÿóÃ4í÷*ÀeÿÚ[¨(JgKjM1ïéYKûݫˡñ''Á •ú­“X-ŠÈ†#ÑcD ÚñäÈä9J€ƒAËÆŒ ådì5.ÓòMó-p© ŽÄ™É—G¥ïª|v¹÷za³8?íÿî1äqèšÃA6q“Q­¶å•P/šNðiÞð´Mƒ <-ß'ÃYš"œ„Ö>Å6J&6F äz›¯óÒ}i¾Í4¸gÈ¡M§|"¾dzú¶3¬‰ñ5È3P ÷fM^¦¾ÝÊŸ¯r[ 'XçÇÇŽ“Ä5bôMüL\µ ßfúIèJåÒñ¥e8”«·çe=ÄcœbÞøK\¤Ù-«¾gçHÀ«‚8¼ ) Ö‚‡oà„]~Ò·ûøù\ ðÿáüm¦s¾9Gj¿€-c¦Õ¯;Ø'g7©Çpdcšc Ô&®ÄŒ‹ö¼bük´pº_̨a±±¾);\› ¿ù?ë”í´¹àÊ$–ïZ#s4gTÓ¢o} cõf)3Ÿ´qQm,˯¢3Ì!àxBL¾Án"‚Í'SÑñ·%µäàÚV)½¸d/æ›êñMu–þøL +íÌÑZº¥w—Xl¥ëLÍbs¢*¯§6%¢C±<•óÔ ËÂëLëÊT @Zžß‚¬eÍÉ€ÛʱÈË+¡‡î Z¥báªèž8\ŸMƒ‡Jnƒ/œõ„‘—™A,îfSÕ)G©ÑŒ´ëj±âÀ/5@±À“•K“³Sdwþ73ÑÙ´ ãW¾¸Y\‰ß”¡ø;¸;ކr×õà ÒÉ+ˆ*4RúDEvÆS¯¶Ñö¸7œ"ä>*ÉD»‡¾ŠÂƒ§Ò)JskÝoð³E¦ïuPZÁ„FÍ~U2w Ë2•ðÙ€Û ßtˆ˜AY9rÓúæ‚ës׺¨ÿ…Í‚lOŽ}¦!L72ÌzðIBHú$Gç$ò¬öûàfBúŧ”“_Áßw•l/˜¬‡Š›ð탡àÜKžº… î+|! >õˆ}šúz W›ÍÞlí3ºáÆ™užïA¡öì ãÛ(Àßø2ña8dl=sкF¸÷Z"Ê›\‚ÿIÏ™—•ZÌäÐôI „ß½cN ª.)¸U Šg"ôðбµ¾!òv5……v±3µ[ÕFàþßñ”+õž–û§lü¡—T½½V#`™*ÙWY·(3@÷hF.á@¦)""˾+ÈZ-gmß«àbTg(` V;±ï¯™7á¥(sÈ[‚j0WdD|öÅHl gË6` Ý¥öśչ¥ÖÎGÝ•…@=|×}U¾1*U\Wë"ÊÐ;ædöº@·øy×c2±½k‚óžIµçÌ;—·ºÁ‰Öh´U¥é­˜Œ¾fï^á€ÙÆâ•Ô¦<ޝhóÍåÍU šÉœ* íâÞ¸Û‚¬ áºLgIð຿eXËëá8 ÷µ=ñÐõÇ~ƒ‚×È¿"å|uñ¹Ø¼*oò–¹óG¬Ôx̸ËÒŒµˆ¸MæÔnùˆSÏÃ<žé± Š: œ¨MØO 3I y¡l«Ú˜h+nîCî”3µ‚3Ž«&ƒkÛYÙd-éüÄï~?Ý,VëÎWŸáøWBÇ*aEˈkË{O)^¨ÆØX‘âi/†*sMÿÖ}U‹%gõ~ÁÒªÐÚBxÒª9CF8e¸ÕñÝãôaÄVp|B›„UÖZÙËðñ/’Ý©¡é»gŠÈ;ìÖom¦­´D©ª”‡´j1Ä‹n›÷9Y{3®}—º¦>NþçWÍésÿm»!JtK„å?¶07w´†^s#¨BÖšˆ×~Öж2î|wÊqÐ! (ˆ Œ›?0ÇÀþ|Å—6WlQëD\ºb7×í¶¿ÒZ¿ù`U¦M¯ ¦*º{žà‹þL± «c‚P»8éÌg°°‹ºB-…S'›í‚¦DÂ1S"ìL-”N/ç¸{Äõ¼Máôò»BüÁϺ ,Y_ôúŠ<©_*ÍíQœ5ÕžÃ~ÒÃp=·ZC÷ ü"Ò¥†:iŽdê~%ïvÙÆ1ëîo&çA *ýŸÐšáH»J=w¸|-9h–[öD³´ñŽ€B²Z‚l€ó<Ü›M_Ÿ1×mÞ>—_JõÕNóÞ§Á ÕðŽbgÐ×GûzNK‡YÓócë±­õÞ~Ê”:/àÝŽ‡tT–êèy¤òÝwêÄ\VMðHþ;ïè³Oûb>P×w`å4UMhÊ ôpºXX?¨t.8£E¹ÛÙmfŽ´N–â»üÌOò¡¾`™‚ÓňÞBù¯6T¾^vY çdD‘ÜA8˜l¥èéõq÷Ä?§Ìûºfñbyè ¾ TV³ûrûnJ$Ï´è_õ=ƒ”ùMžÖÁêƒ5VIíé² ÚU*b=*&—vs£3ExU(üŽ61Rš¶L)d£(²e¦ÉWä<±C8ž¤ñ2u8*?|H_Ý(_+CÙuEŸbgÛ†FöDæ}vI?ØlŸGQ¯tpÅ™ârÝ•aóð,°r†Mÿ*:÷!¥ƒhfÉE*‰|ßÃÔØj¾zN<ñw{ßJ.™Añ¥~﨩>‡ó“Y QÛ¯ =¾¯Q£œG“…µëÜEÉæ»Èþ% ![Êk£¿íšGåk¨ƒ ÑôsnC/FHYN†áÐ1‰mü7$A ÖÉœ½Ÿ\&„^è@¸bÒf/«È¶1ÍüPÓdwø÷»€Öp…”6wÐ^ôõÎkƒ+Ð[ÿù"uû1ëè#sn|Á½´Tt!ªÄN‘|ä-¾*ZÅ~ˆ© ÏÞ²ºP€uÉ™c‘éçWæ„q9ÉBÆŸÁÓííwi…‚QQêã›*ÕRUi¹qQøÍ¼oÕ¯‰ÜŒ^˪+A¹_$$YY—¢³­›Àˆ×ÏÝ8ûsÅ~µ‹åÐø·EþªÞÛ‚KBÙalÜû G³³á´Ä§ò}wµeY†Âp°0p¥ïŒgn\J~z«Ù3ˆ¾Ž Py½Û]oÚšÜqØ¢^R+ðurÞÔ²"ùæJñ7㸥éúÙ‹Þνև+Þ‰.¤P) {!^ò4qLð£p÷Íý1ýĶõf»éega•ÞåÞш¥ T, Šœö7Ó1E¡Êh2ѱ]ØHº…‚÷^M±SuÙ!)5féøvô…¤—#iqòˆ¢w0oßÔ<û¸ìÒ‰†7*û[L@|ª¦Û“—9·Òeù:@èü‚— ›”Õ¡K‰%~†ï3ÙPϰï{g©OL®ÆRí‚ã|¨Ã~ïSA„ŒNâ>˦äšíýAù¢&?­xƒgÌgwoX§Z¤þL?NUxÕèXõ!é¿;ñ“8tpµ4Öô¹c£ôÊg±$ýÓ/wJñ”-LV êmQÔºA·r;Õ<ø„/;ꊙ=5ð8Ó,‰ÙN>ééSz#Û¡ÜÛ.ž¬I[ÿèȺ®Ot­!/}R—Gxƒüù”eÚo‚o-ÏKÎèTbõbl{8ˆ Z¥æŠJå–‰è#AÈX—²õrQ¹¨€†Ž©\XaéØßñøÞm½Eåz“YÖíŸ:ù6ôåA·¤ô]áý5"-_PÓKØ=»ØJÆGâëËüQ#ÖJ«×Ó(zI}8ªÜ?«*[-þÍ((`¶, ÌM¤ea†Šø!S¾NOûÁDxµèµµK10›ãçb‹Ø—¦üB DBÔ÷½Ñ¦eKȉýsÖ^Ç0½šò©´‡Õ¨¨l’—îyGÅû eƒþ`/·v•½ýå“Ù8~!=ßìÉÚ¯7ÌÔÖEáê¾ÜÏ—$H]cÒÊ}”æ_Ž0Ø•H 5«Îqãþ«ŠRŽi¶ ÄØo3ýÓ«ã*=¸~¯Q€ötä2‘ I5;'Å;‡[ÔntàIØûEágÏÍàü€B'ñ¯†’ÞG™SBKzIWŸ[—ôùü›*¦h_~ˆ|6Èâ<|âlaúj«½d¨©0›Ì˜­­(Ì[§¤ªf»ÍÓó—…ÌôDaMš4JÉ€Ë =~þæPoÿ׈Šì¼+J?™„¾90Æ3Ôb„0¿¤Á×!ÓréÌ¥Ü=ŽS’äR=Ól m;=/œ~ò9Z"mš#(2¸œx‘åì?p_dâ÷é(DièBªÁ¹Í×kŒábÜ‹6‰=2¯ÄDª¶&¸þKRîÏv?ÖÝ TPA¿gýŒ‘‰,ßòqáý÷¾ µfÃÞÙŠd—\²¿îL;šÏΊõàÝ̧hd‘_;‡àÒÈÒóvSýaû Ãݯ¿lq²s™S‚“³8R»N@ëFƒ1|­ Y¸Uør¬ÃO¾ÎõQ]Ç–õÌNÎî#Y§MqwYméµu/ÑÆÍämwÚà ÀÚ8i¹°%I¦ñ‰Z¶fkÞ½(…Ç™u=téÜwÍýk,}øAxîíÿ›ðvÀ0É{šfµuK…Þ9ÈÁ|Œà ©ÕÄ'Ha¦á“Ù§2Ö ­ˆ[‚y¡€½( øªkLÌ‘FM“¾K7…Nãj$jjçÐ%š£*€k„Ó&­F–;'£ÿÒìPùï¾Ç¤’¤i¯Ä¹¦>?.1F¥}Í3µåô_®½÷â:'6š$w/õߟ÷Ž—€xm„×^XÉ꺗bÇáWât»è[ßlbÞh÷ÃÄÏ«à{ÙúûðÙš  jéÄ;O GϪâbâ—Q? `t¾Å/$9² [uW÷ÜÓ=®+†Ùݦ¨ˆ¸:üØ€€{êSÖ Gñ‘HoÍEcl#’åµ:+ÛÙÆÀÌcà&x’¡rK“ÕÚOÑÈM™ñ.ÚrØGÑ›¹jÎ=”`ãí¥y+Ðd‘g.%˲æ*ÌfjŽ¿ó Ú¥¹ š‚ŠÅÚ:`_ÒÐ9¶ÚòPìúO¿§9¥¾²D Í~.«ýŠgÐURLk¶õ[éô¥ƒ¶Ó´UÝtÑcŠA†ËÂìë‚MFzÉΓÏ.þ2scz«°¬ª©ñuîI>0 ‹YZclubSandwich/NAMESPACE0000644000176200001440000000543314634640072014112 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(as.matrix,clubSandwich) S3method(augmented_model_matrix,default) S3method(augmented_model_matrix,plm) S3method(bread,geeglm) S3method(bread,gls) S3method(bread,lme) S3method(bread,lmerMod) S3method(bread,mlm) S3method(bread,plm) S3method(bread,rma.mv) S3method(bread,rma.uni) S3method(bread,robu) S3method(coef_CS,default) S3method(coef_CS,lme) S3method(coef_CS,lmerMod) S3method(coef_CS,mlm) S3method(coef_CS,rma.ls) S3method(coef_CS,robu) S3method(model_matrix,default) S3method(model_matrix,geeglm) S3method(model_matrix,glm) S3method(model_matrix,gls) S3method(model_matrix,ivreg) S3method(model_matrix,lme) S3method(model_matrix,lmerMod) S3method(model_matrix,mlm) S3method(model_matrix,plm) S3method(model_matrix,rma.ls) S3method(model_matrix,robu) S3method(na.action,rma) S3method(print,Wald_test_clubSandwich) S3method(print,clubSandwich) S3method(print,coef_test_clubSandwich) S3method(print,conf_int_clubSandwich) S3method(residuals_CS,default) S3method(residuals_CS,geeglm) S3method(residuals_CS,glm) S3method(residuals_CS,lme) S3method(residuals_CS,lmerMod) S3method(residuals_CS,mlm) S3method(residuals_CS,plm) S3method(residuals_CS,rma) S3method(residuals_CS,robu) S3method(targetVariance,default) S3method(targetVariance,geeglm) S3method(targetVariance,glm) S3method(targetVariance,gls) S3method(targetVariance,lme) S3method(targetVariance,lmerMod) S3method(targetVariance,mlm) S3method(targetVariance,plm) S3method(targetVariance,rma.mv) S3method(targetVariance,rma.uni) S3method(targetVariance,robu) S3method(v_scale,default) S3method(v_scale,geeglm) S3method(v_scale,glm) S3method(v_scale,lm) S3method(v_scale,lme) S3method(v_scale,lmerMod) S3method(v_scale,mlm) S3method(v_scale,plm) S3method(v_scale,rma.mv) S3method(v_scale,robu) S3method(vcovCR,default) S3method(vcovCR,geeglm) S3method(vcovCR,glm) S3method(vcovCR,gls) S3method(vcovCR,ivreg) S3method(vcovCR,lm) S3method(vcovCR,lme) S3method(vcovCR,lmerMod) S3method(vcovCR,mlm) S3method(vcovCR,plm) S3method(vcovCR,rma.mv) S3method(vcovCR,rma.uni) S3method(vcovCR,robu) S3method(weightMatrix,default) S3method(weightMatrix,geeglm) S3method(weightMatrix,glm) S3method(weightMatrix,gls) S3method(weightMatrix,lme) S3method(weightMatrix,lmerMod) S3method(weightMatrix,mlm) S3method(weightMatrix,plm) S3method(weightMatrix,rma.mv) S3method(weightMatrix,rma.uni) S3method(weightMatrix,robu) S3method(weights,robu) export(Wald_test) export(coef_test) export(conf_int) export(constrain_equal) export(constrain_pairwise) export(constrain_zero) export(findCluster.rma.mv) export(impute_covariance_matrix) export(linear_contrast) export(pattern_covariance_matrix) export(vcovCR) import(stats) importFrom(sandwich,bread) clubSandwich/NEWS.md0000644000176200001440000002070214634640466013774 0ustar liggesusers# clubSandwich 0.5.11 * Corrected a unit test related to the plm package, for compatibility with upcoming release of plm. * Deprecated `impute_covariance_matrix()` and `pattern_covariance_matrix()`, because they have been superseded by `metafor::vcalc()`. # clubSandwich 0.5.10 * Fixed another bug in `linear_contrast()` to handle specified contrasts that are scalars when variance-covariance matrix is computed with a working model that is not inverse-variance. * Fixed formatting of package version numbers in unit tests to conform to changes in `packageVersion()` in R-devel. # clubSandwich 0.5.9 * Added support for `geepack::geeglm()` models. * Added support for `rma.ls` models (location-scale models estimated using `metafor::rma.uni(scale = )`). * Improved error handling of `Wald_test()` when vcov of contrasts is not positive definite. * Fixed a bug in `linear_contrast()` to handle specified contrasts that are scalars. * Improved internal `get_data` function for `gls` and `lme` objects to allow use of expressions in addition to object names. # clubSandwich 0.5.8 * Added support for `ivreg::ivreg` objects when estimated by ordinary least squares (support for objects estimated by 2SM and 2SMM is not yet implemented). * Updated unit tests for `plm::plm()` when `method = "FD"` to account for bug fixes in version 2.6-2 of plm. # clubSandwich 0.5.7 * Fixed bug in methods for multi-variate multi-level models estimated with lme(). * Updated vignettes, examples, and unit tests so that the package can be compiled without any packages from SUGGESTS. # clubSandwich 0.5.6 * Corrected bug in methods for `plm` objects estimated by random effects, which occurred when a user-specified clustering variable was at a higher level than the random effects. * Added support for `plm` objects with nested random effects (`effects = "nested"`). * Added additional syntactic options for specifying clustering variable with `plm` objects. See `?plm`. * Corrected bug in how `Wald_test()` labeled results when `test = "Naive-Fp"`. # clubSandwich 0.5.5 * New function `linear_contrast()` calculates robust confidence intervals and p-values for linear contrasts of regression coefficients from a fitted model. Works with `constrain_pairwise()` and other `constrain_*()` helper functions. * Corrected precision of unit test leading to error on M1mac. # clubSandwich 0.5.4 ## New features * `Wald_test()` gains an option for `test = "Naive-Fp"`, which uses denominator degrees of freedom equal to the number of clusters minus the number of coefficients in the fitted model. * `coef_test()` and `conf_int()` gain an option for `test = "naive-tp"`, which uses denominator degrees of freedom equal to the number of clusters minus the number of coefficients in the fitted model. ## Minor improvements and bug fixes * Corrected a bug in the Satterthwaite degrees of freedom calculations for models that include only an intercept. * Output of `coef_test()` and `conf_int()` now include a variable containing the coefficient names, so that the results are "tidy." * `conf_int()` now includes an option to report a p-value for each coefficient. * `coef_test()` now reports degrees of freedom for `test = 'z'` and `test = 'naive-t'`. * `vcovCR()` now provides a more informative error message when the clustering variable is a constant. * `vcovCR()` now handles models estimated using analytic weights, where some weights are equal to zero. Results are consistent with omitting observations with weights of zero. * Added more informative error messages for `Wald_test()` and `conf_int()`, triggered if the test argument does not match any of the available tests. * Corrected a bug in `findCluster.rma.mv()`, which threw an error if a random effects factor in the rma.mv model had unobserved levels. * Corrected a bug in `Wald_test()`, which threw an error for tests of intercept-only models. * Fixed a minor bug in print method for `Wald_test()` results, which threw an error when the p-value was `NA`. # clubSandwich 0.5.3 * Removed dependency on mathjaxr # clubSandwich 0.5.2 * Added mathjaxr to Imports # clubSandwich 0.5.1 ## New features * New functionality for `impute_covariance_matrix()`: * Compute covariance matrices with AR1 correlation structure or with a combination of constant correlation and AR1 correlation structure. * Compute covariance matrices that are blocked by subgroup. * Average the variance estimates by cluster before computing covariance matrices. * New function `pattern_covariance_matrix()`, which creates a covariance matrix based on a specified pattern of correlations between different categories of effects. ## Minor improvements and bug fixes * Corrected bug in methods for `rma.mv` objects, which previously led to incorrect identification of clustering variables in models with multiple levels of random effects, where at least one set of random effects has inner | outer structure. # clubSandwich 0.5.0 ## New features: a major update to `Wald_test()` * `Wald_test()` now uses new helper functions `constrain_zero()`, `constrain_equal()`, and `constrain_pairwise()` to specify constraint matrices. * `Wald_test()` gains an argument `tidy`. When `TRUE`, results for a list of tests will be tidied into a single data.frame. * Output of `Wald_test()` now includes both numerator and denominator degrees of freedom. ## Minor improvements and bug fixes * Corrected bug in methods for `plm` objects, which occurred when "within" models included cluster-level interactions. Previously main effects of cluster-level variables were not getting dropped from `model_matrix.plm()`. * Corrected bugs in methods for `robu` objects * Corrected a bug that previously led to errors for models with only one column in the model matrix (i.e., intercept-only models). * Corrected a bug in an internal function that previously led to errors in `constrain_equal()` and `constrain_zero()` when called on robu objects. # clubSandwich 0.4.2 * Updated and streamlined unit tests for R 4.0.0. # clubSandwich 0.4.1 * Updated unit tests to satisfy obscure CRAN checks. # clubSandwich 0.4.0 * Added methods for `lmerMod` objects fitted by `lme4::lmer()`. * Updated internals to use `inherits()` instead of checking `class()` directly. # clubSandwich 0.3.5 * Added t statistics to output of `coef_test()`. * Fixed a bug in `get_index_order()`, an internal function used with plm objects. Previously, the function assumed that both individual and time indices were specified in the `plm` call. The new function works even when zero or one indices are specified. # clubSandwich 0.3.3 * `impute_covariance_matrix()` now drops unobserved factor levels. * updated method for handling residuals from `rma.uni` and `rma.mv` objects, for consistency with metafor 2.1-0. # clubSandwich 0.3.2 * Added `conf_int()` to provide easy cluster-robust confidence intervals. * Added examples to documentation for `conf_int()` and `coef_test()`. # clubSandwich 0.3.1 * Added `coefs` option to `coef_test()` to allow testing of subsets of coefficients. * Updated tests to use `carData` instead of car package. # clubSandwich 0.3.0 * Added methods for `ivreg` objects. * Added methods for `mlm` objects. * Updated `residuals_CS.plm` to account for changes in plm 1.6-6. # clubSandwich 0.2.3 ## New features * Added methods for `glm` objects. * Provide facility to cluster at higher level than highest random effects for `lme` and `gls` objects. * Added `impute_covariance_matrix()` utility function for multivariate meta-analysis. ## Minor improvements and bug fixes * Updated methods for plm objects to account for changes in plm 1.6-6. * Added documentation of `type` options in `vcovCR()`. * Added examples for all `vcovCR()` methods. # clubSandwich 0.2.2 ## New features * Added `bread()` methods for all supported model classes. * `vcovCR()` is now calculated using `bread()`, and carries attributes for `bread`, `est_mat`, and adjustment matrices. * `vcovCR()` gains a `form` argument to obtain just the meat of the sandwich, or to use a user-specified bread matrix. ## Minor improvements and bug fixes * Refactored internal functions for degrees of freedom calculation to improve speed and memory usage. * Bug fixes: - updated `nobs.plm()` method to handle first-differenced models # clubSandwich 0.2.1 * First version released on CRAN. clubSandwich/inst/0000755000176200001440000000000014635065010013635 5ustar liggesusersclubSandwich/inst/doc/0000755000176200001440000000000014635065010014402 5ustar liggesusersclubSandwich/inst/doc/Wald-tests-in-clubSandwich.Rmd0000644000176200001440000005372014630154052022114 0ustar liggesusers--- title: "Wald tests of multiple-constraint null hypotheses" author: "James E. Pustejovsky" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: number_sections: true toc: true bibliography: bibliography.bib csl: apa.csl vignette: > %\VignetteIndexEntry{Wald tests of multiple-constraint null hypotheses} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, echo = FALSE, results = "asis", message = FALSE, warning = FALSE} library(clubSandwich) AER_available <- requireNamespace("AER", quietly = TRUE) knitr::opts_chunk$set(eval = AER_available) if (!AER_available) cat("# Building this vignette requires the AER package. Please install it. {-}") ``` Version 0.5.0 of `clubSandwich` introduced a new syntax for `Wald_test()`, a function for conducting tests of multiple-constraint hypotheses. In previous versions, this function was poorly documented and, consequently, probably little used. This vignette will demonstrate the new syntax. For purposes of illustration, I will use the `STAR` data (available in the `AER` package), which is drawn from a randomized trial evaluating the effects of elementary school class size on student achievement. The data consist of individual-level measures for students in each of several dozen schools. For purposes of illustration, I will look at effects on math performance in first grade. Treatment conditions (the variable called `stark`) were assigned at the classroom level, and consisted of either a) a regular-size class, b) a small-size class, or c) a regular-size class but with the addition of a teacher's aide. In all of what follows, I will cluster standard errors by school in order to allow for generalization to a super-population of schools. ```{r, message = FALSE, warning = FALSE} library(clubSandwich) data(STAR, package = "AER") # clean up a few variables levels(STAR$stark)[3] <- "aide" levels(STAR$schoolk)[1] <- "urban" STAR <- subset(STAR, !is.na(schoolidk), select = c(schoolidk, schoolk, stark, gender, ethnicity, math1, lunchk)) head(STAR) ``` # The Wald test function The `Wald_test()` function can be used to conduct hypothesis tests that involve multiple constraints on the regression coefficients. Consider a linear model for an outcome $Y_{ij}$ regressed on a $1 \times p$ row vector of predictors $\mathbf{x}_{ij}$ (which might include a constant intercept term): $$ Y_{ij} = \mathbf{x}_{ij} \boldsymbol\beta + \epsilon_{ij} $$ The regression coefficient vector is $\boldsymbol\beta$. In quite general terms, a set of constraints on the regression coefficient vector can be expressed in terms of a $q \times p$ matrix $\mathbf{C}$, where each row of $\mathbf{C}$ corresponds to one constraint. A joint null hypothesis is then $H_0: \mathbf{C} \boldsymbol\beta = \mathbf{0}$, where $\mathbf{0}$ is a $q \times 1$ vector of zeros.[^more-general] [^more-general]: In @pustejovsky2018small we used a more general formulation of multiple-constraint null hypotheses, expressed as $H_0: \mathbf{C} \boldsymbol\beta = \mathbf{d}$ for some fixed $q \times 1$ vector $\mathbf{d}$. In practice, it's often possible to modify the $\mathbf{C}$ matrix so that $\mathbf{d}$ can always be set to $\mathbf{0}$. Wald-type test are based on the test statistic $$ Q = \left(\mathbf{C}\boldsymbol{\hat\beta}\right)' \left(\mathbf{C} \mathbf{V}^{CR} \mathbf{C}'\right)^{-1} \left(\mathbf{C}\boldsymbol{\hat\beta}\right), $$ where $\boldsymbol{\hat\beta}$ is the estimated regression coefficient vector and $\mathbf{V}^{CR}$ is a cluster-robust variance matrix. If the number of clusters is sufficiently large, then the distribution of $Q$ under the null hypothesis is approximately $\chi^2(q)$. @tipton2015small investigated a wide range of other approximations to the null distribution of $Q$, many of which are included as options in `Wald_test()`. Based on a large simulation, they (...er...we...) recommended a method called the "approximate Hotelling's $T^2$-Z" test, or "AHZ." This test approximates the distribution of $Q / q$ by a $T^2$ distribution, which is a multiple of an $F$ distribution, with numerator degrees of freedom $q$ and denominator degrees of freedom based on a generalization of the Satterthwaite approximation. The `Wald_test()` function has three main arguments: ```{r} args(Wald_test) ``` * The `obj` argument is used to specify the estimated regression model on which to perform the test, * the `constraints` argument is a $\mathbf{C}$ matrix expressing the set of constraints to test, and * the `vcov` argument is a cluster-robust variance matrix, which is used to construct the test statistic. (Alternately, `vcov` can be the type of cluster-robust variance matrix to construct, in which case it will be computed internally.) By default, `Wald_test()` will use the HTZ small-sample approximation. Other options are available (via the `test` argument) but not recommended for routine use. The optional `tidy` argument will be demonstrated below. ## Testing treatment effects Returning to the STAR data, let's suppose we want to examine differences in math performance across class sizes. This can be done with a simple linear regression model, while clustering the standard errors by `schoolidk`. The estimating equation is $$ \left(\text{Math}\right)_{ij} = \beta_0 + \beta_1 \left(\text{small}\right)_{ij} + \beta_2 \left(\text{aide}\right)_{ij} + e_{ij}, $$ which can be estimated in R as follows: ```{r type-treat} lm_trt <- lm(math1 ~ stark, data = STAR) V_trt <- vcovCR(lm_trt, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_trt, vcov = V_trt) ``` In this estimating equation, the coefficients $\beta_1$ and $\beta_2$ represent treatment effects, or differences in average math scores relative to the reference level of `stark`, which in this case is a regular-size class. The t-statistics and p-values reported by `coef_test` are separate tests of the null hypotheses that each of these coefficients are equal to zero, meaning that there is no difference between the specified treatment condition and the reference level. We might want to instead test the _joint_ null hypothesis that there are no differences among _any_ of the conditions. This null can be expressed by a set of multiple constraints on the parameters: $\beta_1 = 0$ and $\beta_2 = 0$. To test the null hypothesis that $\beta_1 = \beta_2 = 0$ based on the treatment effects model specification, we can use: ```{r} C_trt <- matrix(c(0,0,1,0,0,1), 2, 3) C_trt Wald_test(lm_trt, constraints = C_trt, vcov = V_trt) ``` The result includes details about the form of `test` computed, the $F$-statistic, the numerator and denominator degrees of freedom used to compute the reference distribution, and the $p$-value corresponding to the specified null hypothesis. In this example, $p = `r if (AER_available) format.pval(Wald_test(lm_trt, constraints = C_trt, vcov = V_trt)$p_val, digits = 3)`$, so we can rule out the null hypothesis that there are no differences in math performance across conditions. The representation of null hypotheses as arbitrary constraint matrices is useful for developing theory about how to test such hypotheses, but it is not all that helpful for actually running tests---constructing constraint matrices "by hand" is just too cumbersome of an exercise. Moreover, $\mathbf{C}$ matrices typically follow one of a small number of patterns. Two common use cases are a) constraining a set of $q > 1$ parameters to all be equal to zero and b) constraining a set of $q + 1$ parameters to be equal to a common value. The `clubSandwich` package now includes a set of helper functions to create constraint matrices for these common use cases. ## `constrain_zero()` To constrain a set of $q$ regression coefficients to all be equal to zero, the simplest form of the $\mathbf{C}$ matrix would consist of a set of $q$ rows, where a single entry in each row would be equal to 1 and the remaining entries would all be zero. For the `lm_trt` model, the C matrix would look like this: $$ \mathbf{C} = \left[\begin{array}{ccc} 0 & 1 & 0 \\ 0 & 0 & 1 \end{array} \right], $$ so that $$ \mathbf{C}\boldsymbol\beta = \left[\begin{array}{ccc} 0 & 1 & 0 \\ 0 & 0 & 1 \end{array} \right] \left[\begin{array}{c} \beta_0 \\ \beta_1 \\ \beta_2 \end{array} \right] = \left[\begin{array}{c} \beta_1 \\ \beta_2 \end{array} \right], $$ which is set equal to $\left[\begin{array}{c} 0 \\ 0 \end{array} \right]$. The `constrain_zero()` function will create matrices like this automatically. The function takes two main arguments: ```{r} args(constrain_zero) ``` * The `constraints` argument is used to specify _which_ coefficients in a regression model to set equal to zero. * The `coefs` argument is the set of estimated regression coefficients, for which to calculate the constraints. Constraints can be specified by position index, by name, or via a regular expression. To test the joint null hypothesis that average math performance is equal across the three treatment conditions, we need to constrain the second and third coefficients to zero: ```{r} constrain_zero(2:3, coefs = coef(lm_trt)) ``` Or equivalently: ```{r} constrain_zero(c("starksmall","starkaide"), coefs = coef(lm_trt)) ``` or ```{r} constrain_zero("^stark", coefs = coef(lm_trt), reg_ex = TRUE) ``` Note that if `constraints` is a regular expression, then the `reg_ex` argument needs to be set to `TRUE`. The result of `constrain_zero()` can then be fed into the `Wald_test()` function: ```{r} C_trt <- constrain_zero(2:3, coefs = coef(lm_trt)) Wald_test(lm_trt, constraints = C_trt, vcov = V_trt) ``` To reduce redundancy in the syntax, we can also omit the `coefs` argument to `constrain_zero`, so long as we call it inside of `Wald_test`[^under-the-hood]: ```{r} Wald_test(lm_trt, constraints = constrain_zero(2:3), vcov = V_trt) ``` [^under-the-hood]: How does this work? If we omit the `coefs` argument, `constrain_zero()` acts as a functional, by returning a function equivalent to `function(coefs) constrain_zero(constraints, coefs = coefs)`. If this function is fed into the `constraints` argument of `Wald_test()`, `Wald_test()` recognizes that it is a function and evaluates the function with `coef(obj)`. It's a kinda-sorta hacky substitute for lazy evaluation. If you have suggestions for how to do this more elegantly, please send them my way. ## `constrain_equal()` Another common type of constraints involve setting a set of $q + 1$ regression coefficients to be all equal to a common (but unknown) value ($q + 1$ because it takes $q$ constraints to do this). There are many equivalent ways to express such a set of constraints in terms of a $\mathbf{C}$ matrix. One fairly simple form consists of a set of $q$ rows, where the entry corresponding to one of the coefficients of interest is equal to -1 and the entry corresponding to another coefficient of interest is equal to 1. To see how this works, let's look at a different way of parameterizing our simple model for the STAR data, by using separate intercepts for each treatment condition. The estimating equation would then be $$ \left(\text{Math}\right)_{ij} = \beta_0 \left(\text{regular}\right)_{ij} + \beta_1 \left(\text{small}\right)_{ij} + \beta_2 \left(\text{aide}\right)_{ij} + e_{ij}. $$ This model can be estimated in R by dropping the intercept term: ```{r type-sep} lm_sep <- lm(math1 ~ 0 + stark, data = STAR) V_sep <- vcovCR(lm_sep, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_sep, vcov = V_sep) ``` In this parameterization, the coefficients $\beta_0$, $\beta_1$, and $\beta_2$ represent the average math performance levels of students in each of the treatment conditions. The t-tests and p-values now have a very different interpretation because they pertain to the null hypothesis that the average performance level for a given condition is equal to zero. With this separate-intercepts model, the joint null hypothesis that performance levels are equal across conditions amounts to constraining the intercepts to be equal to each other: $\beta_0 = \beta_1$ and $\beta_0 = \beta_2$ (note that we don't need the constraint $\beta_1 = \beta_2$ because it is implied by the first two). For the `lm_sep` model, which has separate intercepts $\beta_0$, $\beta_1$, and $\beta_2$, the C matrix would look like this: $$ \mathbf{C} = \left[\begin{array}{ccc} -1 & 1 & 0 \\ -1 & 0 & 1 \end{array} \right], $$ so that $$ \mathbf{C}\boldsymbol\beta = \left[\begin{array}{ccc} -1 & 1 & 0 \\ -1 & 0 & 1 \end{array} \right] \left[\begin{array}{c} \beta_0 \\ \beta_1 \\ \beta_2 \end{array} \right] = \left[\begin{array}{c} \beta_1 - \beta_0 \\ \beta_2 - \beta_0 \end{array} \right], $$ which is set equal to $\left[\begin{array}{c} 0 \\ 0 \end{array} \right]$. The `constrain_equal()` function will create matrices like this automatically, given a set of coefficients to constrain. The syntax is identical to `constrain_zero()`: ```{r} args(constrain_equal) ``` To test the joint null hypothesis that average math performance is equal across the three treatment conditions, we can constrain all three coefficients of `lm_sep` to be equal: ```{r} constrain_equal(1:3, coefs = coef(lm_sep)) ``` Or equivalently: ```{r} constrain_equal(c("starkregular","starksmall","starkaide"), coefs = coef(lm_sep)) ``` or ```{r} constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE) ``` Just as with `constrain_zero`, if `constraints` is a regular expression, then the `reg_ex` argument needs to be set to `TRUE`. This constraint matrix can then be fed into `Wald_test()`: ```{r} C_sep <- constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE) Wald_test(lm_sep, constraints = C_sep, vcov = V_sep) ``` or equivalently: ```{r} Wald_test(lm_sep, constraints = constrain_equal(1:3), vcov = V_sep) ``` Note that these test results are exactly equal to the tests based on `lm_trt` with `constrain_zero()`. They're algebraically equivalent---just different ways of parameterizing the same model and constraints. # Testing an interaction Let's now consider how these functions can be applied in a more complex model. Suppose that we are interested in understanding whether the effect of being in a small class is consistent across schools in different areas, where areas are categorized as urban, suburban, or rural. To answer this question, we need to test for an interaction between urbanicity and treatment condition. One estimating equation that would let us examine this question is: $$ \begin{aligned} \left(\text{Math}\right)_{ij} &= \beta_0 + \beta_1 \left(\text{suburban}\right)_{ij} + \beta_2 \left(\text{rural}\right)_{ij} \\ & \quad + \beta_3 \left(\text{small}\right)_{ij} + \beta_4 \left(\text{aide}\right)_{ij} \\ & \quad\quad + \beta_5 \left(\text{small}\right)(\text{suburban})_{ij} + \beta_6 \left(\text{aide}\right)(\text{suburban})_{ij} \\ & \quad\quad\quad + \beta_{7} \left(\text{small}\right)(\text{rural})_{ij} + \beta_{8} \left(\text{aide}\right)(\text{rural})_{ij} \\ & \quad\quad\quad\quad + \mathbf{x}_{ij} \boldsymbol\gamma + e_{ij}, \end{aligned} $$ where $\mathbf{x}_{ij}$ is a row vector of student characteristics, included just to make the regression look fancier. In this specification, $\beta_3$ and $\beta_4$ represent the effects of being in a small class or aide class, compared to being in a regular class, but _only for the reference level of urbanicity_---in this case, urban schools. The coefficients $\beta_5, \beta_6, \beta_7, \beta_8$ all represent _interactions_ between treatment condition and urbanicity. Here's the model, estimated in R: ```{r} lm_urbanicity <- lm(math1 ~ schoolk * stark + gender + ethnicity + lunchk, data = STAR) V_urbanicity <- vcovCR(lm_urbanicity, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_urbanicity, vcov = V_urbanicity) ``` With this specification, there are several different null hypotheses that we might want to test. For one, perhaps we want to see if there is _any_ variation in treatment effects across different levels of urbanicity. This can be expressed in the null hypothesis that all four interaction terms are zero, or $H_{0A}: \beta_5 = \beta_6 = \beta_7 = \beta_8 = 0$. With Wald test: ```{r} Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity) ``` Another possibility is that we might want to focus on variation in the effect of being in a small class or regular class, while ignoring whatever is going on in the aide class condition. Here, the null hypothesis would be simply $H_{0B}: \beta_5 = \beta_6 = 0$, tested as: ```{r} Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE), vcov = V_urbanicity) ``` ## Lists of constraints In models like the urbanicity-by-treatment interaction specification, we may need to run multiple tests on the same estimating equation. This can be accomplished with `Wald_test` by providing a _list_ of constraints to the `constraints` argument. For example, we could test the hypotheses described above by creating a list of several constraint matrices and then passing it to `Wald_test`: ```{r} C_list <- list( `Any interaction` = constrain_zero("schoolk.+:stark", coef(lm_urbanicity), reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", coef(lm_urbanicity), reg_ex = TRUE) ) Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity) ``` Setting the option `tidy = TRUE` will arrange the output of all the tests into a single data frame: ```{r} Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity, tidy = TRUE) ``` The list of constraints can also be created inside `Wald_test`, so that the `coefs` argument can be omitted from `constrain_zero()`: ```{r} Wald_test( lm_urbanicity, constraints = list( `Any interaction` = constrain_zero("schoolk.+:stark", reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE) ), vcov = V_urbanicity, tidy = TRUE ) ``` # Pairwise t-tests The `clubSandwich` package also provides a further convenience function, `constrain_pairwise()` that can be used in combination with `Wald_test()` to conduct pairwise comparisons among a set of regression coefficients. This function differs from the other two `constrain_*()` functions because it returns a _list_ of constraint matrices, each of which corresponds to a single linear combination of covariates. Specifically, the `constrain_pairwise()` function provides a list of constraints that represent the differences between every possible pair among a specified set of coefficients. The syntax is very similar to the other `constrain_*()` functions. To demonstrate, consider the separate-intercepts specification of the simpler regression model: ```{r} coef_test(lm_sep, vcov = V_sep) ``` This specification is nice because it lets us simply read off the average outcomes for each group. However, we will naturally also want to know about whether there are differences between the groups, so we'll want to compare the small-class condition to the regular-size class condition, the aide condition to the regular-size class condition, and the small-class condition to the aide condition. Thus, we'll want comparisons among all three coefficients: ```{r} C_pairs <- constrain_pairwise(1:3, coefs = coef(lm_sep)) C_pairs ``` Feeding these constraints into `Wald_test()` gives us significance tests for each pair: ```{r} Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE) ``` The first two of these tests are equivalent to the tests of the treatment effect coefficients in the other parameterization of the model. Indeed, the denominator degrees of freedom are identical to the results of `coef_test(lm_trt, vcov = V_trt)`; the `Fstat`s here are equal to the squared t-statistics from the first model: ```{r} t_stats <- coef_test(lm_trt, vcov = V_trt)$tstat[2:3] F_stats <- Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE)$Fstat[1:2] all.equal(t_stats^2, F_stats) ``` It is important to note that the p-values from the pairwise comparisons are _not_ corrected for multiplicity.[^multiplicity] For now, please correct-your-own using `p.adjust()` or your preferred method. [^multiplicity]: Options to include multiplicity corrections (Bonferroni, Holm, Benjamini-Hochberg, etc.) might be included in a [future release](https://github.com/jepusto/clubSandwich/issues/33). Reach out if this is of interest to you. Pairwise comparisons might also be of use in the model with treatment-by-urbanicity interactions. Here's the model results again: ```{r} coef_test(lm_urbanicity, vcov = V_urbanicity) ``` Suppose that we are interested in the effect of small versus regular size classes, and in particular whether this effect varies across schools in different areas. The coefficients on `schoolksuburban:starksmall` and `schoolkrural:starksmall` already give us the differences in treatment effects between suburban schools versus urban schools and between rural schools versus urban schools. The difference between these coefficients gives us the difference in treatment effects between suburban schools and rural schools. We can look at all three of these contrasts using `constrain_pairwise()` by setting the option `with_zero = TRUE`: ```{r} Wald_test(lm_urbanicity, constraints = constrain_pairwise(":starksmall", reg_ex = TRUE, with_zero = TRUE), vcov = V_urbanicity, tidy = TRUE) ``` Again, the results of the first two tests are identical to the t-tests reported in `coef_test()`. # Remark All of the preceding examples were based on ordinary linear regression models with clustered standard errors. However, `Wald_test()` and its helper functions all work identically for all of the other models with supporting `clubSandwich` methods, including `nlme::lme()`, `nlme::gls()`, `lme4::lmer()`, `rma.uni()`, `rma.mv()`, and `robu()`, among others. # References clubSandwich/inst/doc/Wald-tests-in-clubSandwich.html0000644000176200001440000016660514635065002022346 0ustar liggesusers Wald tests of multiple-constraint null hypotheses

Wald tests of multiple-constraint null hypotheses

James E. Pustejovsky

2024-06-20

Version 0.5.0 of clubSandwich introduced a new syntax for Wald_test(), a function for conducting tests of multiple-constraint hypotheses. In previous versions, this function was poorly documented and, consequently, probably little used. This vignette will demonstrate the new syntax.

For purposes of illustration, I will use the STAR data (available in the AER package), which is drawn from a randomized trial evaluating the effects of elementary school class size on student achievement. The data consist of individual-level measures for students in each of several dozen schools. For purposes of illustration, I will look at effects on math performance in first grade. Treatment conditions (the variable called stark) were assigned at the classroom level, and consisted of either a) a regular-size class, b) a small-size class, or c) a regular-size class but with the addition of a teacher’s aide. In all of what follows, I will cluster standard errors by school in order to allow for generalization to a super-population of schools.

library(clubSandwich)

data(STAR, package = "AER")

# clean up a few variables
levels(STAR$stark)[3] <- "aide"
levels(STAR$schoolk)[1] <- "urban"
STAR <- subset(STAR, 
               !is.na(schoolidk),
               select = c(schoolidk, schoolk, stark, gender, ethnicity, math1, lunchk))
head(STAR)
##      schoolidk  schoolk   stark gender ethnicity math1   lunchk
## 1137        63    rural   small female      cauc   538 non-free
## 1143        20 suburban   small female      afam   592 non-free
## 1183        19    urban    aide   male      afam    NA     free
## 1277        69    rural regular   male      cauc   584 non-free
## 1292        79    rural   small   male      cauc   545     free
## 1308         5    rural regular   male      cauc   553     free

1 The Wald test function

The Wald_test() function can be used to conduct hypothesis tests that involve multiple constraints on the regression coefficients. Consider a linear model for an outcome \(Y_{ij}\) regressed on a \(1 \times p\) row vector of predictors \(\mathbf{x}_{ij}\) (which might include a constant intercept term): \[ Y_{ij} = \mathbf{x}_{ij} \boldsymbol\beta + \epsilon_{ij} \] The regression coefficient vector is \(\boldsymbol\beta\). In quite general terms, a set of constraints on the regression coefficient vector can be expressed in terms of a \(q \times p\) matrix \(\mathbf{C}\), where each row of \(\mathbf{C}\) corresponds to one constraint. A joint null hypothesis is then \(H_0: \mathbf{C} \boldsymbol\beta = \mathbf{0}\), where \(\mathbf{0}\) is a \(q \times 1\) vector of zeros.1

Wald-type test are based on the test statistic \[ Q = \left(\mathbf{C}\boldsymbol{\hat\beta}\right)' \left(\mathbf{C} \mathbf{V}^{CR} \mathbf{C}'\right)^{-1} \left(\mathbf{C}\boldsymbol{\hat\beta}\right), \] where \(\boldsymbol{\hat\beta}\) is the estimated regression coefficient vector and \(\mathbf{V}^{CR}\) is a cluster-robust variance matrix. If the number of clusters is sufficiently large, then the distribution of \(Q\) under the null hypothesis is approximately \(\chi^2(q)\). Tipton & Pustejovsky (2015) investigated a wide range of other approximations to the null distribution of \(Q\), many of which are included as options in Wald_test(). Based on a large simulation, they (…er…we…) recommended a method called the “approximate Hotelling’s \(T^2\)-Z†test, or “AHZ.†This test approximates the distribution of \(Q / q\) by a \(T^2\) distribution, which is a multiple of an \(F\) distribution, with numerator degrees of freedom \(q\) and denominator degrees of freedom based on a generalization of the Satterthwaite approximation.

The Wald_test() function has three main arguments:

args(Wald_test)
## function (obj, constraints, vcov, test = "HTZ", tidy = FALSE, 
##     ...) 
## NULL
  • The obj argument is used to specify the estimated regression model on which to perform the test,
  • the constraints argument is a \(\mathbf{C}\) matrix expressing the set of constraints to test, and
  • the vcov argument is a cluster-robust variance matrix, which is used to construct the test statistic. (Alternately, vcov can be the type of cluster-robust variance matrix to construct, in which case it will be computed internally.)

By default, Wald_test() will use the HTZ small-sample approximation. Other options are available (via the test argument) but not recommended for routine use. The optional tidy argument will be demonstrated below.

1.1 Testing treatment effects

Returning to the STAR data, let’s suppose we want to examine differences in math performance across class sizes. This can be done with a simple linear regression model, while clustering the standard errors by schoolidk. The estimating equation is \[ \left(\text{Math}\right)_{ij} = \beta_0 + \beta_1 \left(\text{small}\right)_{ij} + \beta_2 \left(\text{aide}\right)_{ij} + e_{ij}, \] which can be estimated in R as follows:

lm_trt <- lm(math1 ~ stark, data = STAR)
V_trt <- vcovCR(lm_trt, cluster = STAR$schoolidk, type = "CR2")
coef_test(lm_trt, vcov = V_trt)
##        Coef. Estimate   SE  t-stat d.f. (Satt) p-val (Satt) Sig.
##  (Intercept)  531.727 2.78 191.506        59.9       <0.001  ***
##   starksmall    9.469 2.30   4.114        65.6       <0.001  ***
##    starkaide   -0.483 1.86  -0.259        65.6        0.796

In this estimating equation, the coefficients \(\beta_1\) and \(\beta_2\) represent treatment effects, or differences in average math scores relative to the reference level of stark, which in this case is a regular-size class. The t-statistics and p-values reported by coef_test are separate tests of the null hypotheses that each of these coefficients are equal to zero, meaning that there is no difference between the specified treatment condition and the reference level. We might want to instead test the joint null hypothesis that there are no differences among any of the conditions. This null can be expressed by a set of multiple constraints on the parameters: \(\beta_1 = 0\) and \(\beta_2 = 0\).

To test the null hypothesis that \(\beta_1 = \beta_2 = 0\) based on the treatment effects model specification, we can use:

C_trt <- matrix(c(0,0,1,0,0,1), 2, 3)
C_trt
##      [,1] [,2] [,3]
## [1,]    0    1    0
## [2,]    0    0    1
Wald_test(lm_trt, constraints = C_trt, vcov = V_trt)
##  test Fstat df_num df_denom  p_val sig
##   HTZ  10.2      2     65.3 <0.001 ***

The result includes details about the form of test computed, the \(F\)-statistic, the numerator and denominator degrees of freedom used to compute the reference distribution, and the \(p\)-value corresponding to the specified null hypothesis. In this example, \(p = 0.000141\), so we can rule out the null hypothesis that there are no differences in math performance across conditions.

The representation of null hypotheses as arbitrary constraint matrices is useful for developing theory about how to test such hypotheses, but it is not all that helpful for actually running tests—constructing constraint matrices “by hand†is just too cumbersome of an exercise. Moreover, \(\mathbf{C}\) matrices typically follow one of a small number of patterns. Two common use cases are a) constraining a set of \(q > 1\) parameters to all be equal to zero and b) constraining a set of \(q + 1\) parameters to be equal to a common value. The clubSandwich package now includes a set of helper functions to create constraint matrices for these common use cases.

1.2 constrain_zero()

To constrain a set of \(q\) regression coefficients to all be equal to zero, the simplest form of the \(\mathbf{C}\) matrix would consist of a set of \(q\) rows, where a single entry in each row would be equal to 1 and the remaining entries would all be zero. For the lm_trt model, the C matrix would look like this: \[ \mathbf{C} = \left[\begin{array}{ccc} 0 & 1 & 0 \\ 0 & 0 & 1 \end{array} \right], \] so that \[ \mathbf{C}\boldsymbol\beta = \left[\begin{array}{ccc} 0 & 1 & 0 \\ 0 & 0 & 1 \end{array} \right] \left[\begin{array}{c} \beta_0 \\ \beta_1 \\ \beta_2 \end{array} \right] = \left[\begin{array}{c} \beta_1 \\ \beta_2 \end{array} \right], \] which is set equal to \(\left[\begin{array}{c} 0 \\ 0 \end{array} \right]\).

The constrain_zero() function will create matrices like this automatically. The function takes two main arguments:

args(constrain_zero)
## function (constraints, coefs, reg_ex = FALSE) 
## NULL
  • The constraints argument is used to specify which coefficients in a regression model to set equal to zero.
  • The coefs argument is the set of estimated regression coefficients, for which to calculate the constraints.

Constraints can be specified by position index, by name, or via a regular expression. To test the joint null hypothesis that average math performance is equal across the three treatment conditions, we need to constrain the second and third coefficients to zero:

constrain_zero(2:3, coefs = coef(lm_trt))
##      [,1] [,2] [,3]
## [1,]    0    1    0
## [2,]    0    0    1

Or equivalently:

constrain_zero(c("starksmall","starkaide"), coefs = coef(lm_trt))
##      [,1] [,2] [,3]
## [1,]    0    1    0
## [2,]    0    0    1

or

constrain_zero("^stark", coefs = coef(lm_trt), reg_ex = TRUE)
##      [,1] [,2] [,3]
## [1,]    0    1    0
## [2,]    0    0    1

Note that if constraints is a regular expression, then the reg_ex argument needs to be set to TRUE.

The result of constrain_zero() can then be fed into the Wald_test() function:

C_trt <- constrain_zero(2:3, coefs = coef(lm_trt))
Wald_test(lm_trt, constraints = C_trt, vcov = V_trt)
##  test Fstat df_num df_denom  p_val sig
##   HTZ  10.2      2     65.3 <0.001 ***

To reduce redundancy in the syntax, we can also omit the coefs argument to constrain_zero, so long as we call it inside of Wald_test2:

Wald_test(lm_trt, constraints = constrain_zero(2:3), vcov = V_trt)
##  test Fstat df_num df_denom  p_val sig
##   HTZ  10.2      2     65.3 <0.001 ***

1.3 constrain_equal()

Another common type of constraints involve setting a set of \(q + 1\) regression coefficients to be all equal to a common (but unknown) value (\(q + 1\) because it takes \(q\) constraints to do this). There are many equivalent ways to express such a set of constraints in terms of a \(\mathbf{C}\) matrix. One fairly simple form consists of a set of \(q\) rows, where the entry corresponding to one of the coefficients of interest is equal to -1 and the entry corresponding to another coefficient of interest is equal to 1.

To see how this works, let’s look at a different way of parameterizing our simple model for the STAR data, by using separate intercepts for each treatment condition. The estimating equation would then be \[ \left(\text{Math}\right)_{ij} = \beta_0 \left(\text{regular}\right)_{ij} + \beta_1 \left(\text{small}\right)_{ij} + \beta_2 \left(\text{aide}\right)_{ij} + e_{ij}. \] This model can be estimated in R by dropping the intercept term:

lm_sep <- lm(math1 ~ 0 + stark, data = STAR)
V_sep <- vcovCR(lm_sep, cluster = STAR$schoolidk, type = "CR2")
coef_test(lm_sep, vcov = V_sep)
##         Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##  starkregular      532 2.78    192        59.9       <0.001  ***
##    starksmall      541 2.89    187        65.0       <0.001  ***
##     starkaide      531 2.72    195        64.3       <0.001  ***

In this parameterization, the coefficients \(\beta_0\), \(\beta_1\), and \(\beta_2\) represent the average math performance levels of students in each of the treatment conditions. The t-tests and p-values now have a very different interpretation because they pertain to the null hypothesis that the average performance level for a given condition is equal to zero. With this separate-intercepts model, the joint null hypothesis that performance levels are equal across conditions amounts to constraining the intercepts to be equal to each other: \(\beta_0 = \beta_1\) and \(\beta_0 = \beta_2\) (note that we don’t need the constraint \(\beta_1 = \beta_2\) because it is implied by the first two).

For the lm_sep model, which has separate intercepts \(\beta_0\), \(\beta_1\), and \(\beta_2\), the C matrix would look like this: \[ \mathbf{C} = \left[\begin{array}{ccc} -1 & 1 & 0 \\ -1 & 0 & 1 \end{array} \right], \] so that \[ \mathbf{C}\boldsymbol\beta = \left[\begin{array}{ccc} -1 & 1 & 0 \\ -1 & 0 & 1 \end{array} \right] \left[\begin{array}{c} \beta_0 \\ \beta_1 \\ \beta_2 \end{array} \right] = \left[\begin{array}{c} \beta_1 - \beta_0 \\ \beta_2 - \beta_0 \end{array} \right], \] which is set equal to \(\left[\begin{array}{c} 0 \\ 0 \end{array} \right]\).

The constrain_equal() function will create matrices like this automatically, given a set of coefficients to constrain. The syntax is identical to constrain_zero():

args(constrain_equal)
## function (constraints, coefs, reg_ex = FALSE) 
## NULL

To test the joint null hypothesis that average math performance is equal across the three treatment conditions, we can constrain all three coefficients of lm_sep to be equal:

constrain_equal(1:3, coefs = coef(lm_sep))
##      [,1] [,2] [,3]
## [1,]   -1    1    0
## [2,]   -1    0    1

Or equivalently:

constrain_equal(c("starkregular","starksmall","starkaide"), coefs = coef(lm_sep))
##      [,1] [,2] [,3]
## [1,]   -1    1    0
## [2,]   -1    0    1

or

constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE)
##      [,1] [,2] [,3]
## [1,]   -1    1    0
## [2,]   -1    0    1

Just as with constrain_zero, if constraints is a regular expression, then the reg_ex argument needs to be set to TRUE.

This constraint matrix can then be fed into Wald_test():

C_sep <- constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE)
Wald_test(lm_sep, constraints = C_sep, vcov = V_sep)
##  test Fstat df_num df_denom  p_val sig
##   HTZ  10.2      2     65.3 <0.001 ***

or equivalently:

Wald_test(lm_sep, constraints = constrain_equal(1:3), vcov = V_sep)
##  test Fstat df_num df_denom  p_val sig
##   HTZ  10.2      2     65.3 <0.001 ***

Note that these test results are exactly equal to the tests based on lm_trt with constrain_zero(). They’re algebraically equivalent—just different ways of parameterizing the same model and constraints.

2 Testing an interaction

Let’s now consider how these functions can be applied in a more complex model. Suppose that we are interested in understanding whether the effect of being in a small class is consistent across schools in different areas, where areas are categorized as urban, suburban, or rural. To answer this question, we need to test for an interaction between urbanicity and treatment condition. One estimating equation that would let us examine this question is: \[ \begin{aligned} \left(\text{Math}\right)_{ij} &= \beta_0 + \beta_1 \left(\text{suburban}\right)_{ij} + \beta_2 \left(\text{rural}\right)_{ij} \\ & \quad + \beta_3 \left(\text{small}\right)_{ij} + \beta_4 \left(\text{aide}\right)_{ij} \\ & \quad\quad + \beta_5 \left(\text{small}\right)(\text{suburban})_{ij} + \beta_6 \left(\text{aide}\right)(\text{suburban})_{ij} \\ & \quad\quad\quad + \beta_{7} \left(\text{small}\right)(\text{rural})_{ij} + \beta_{8} \left(\text{aide}\right)(\text{rural})_{ij} \\ & \quad\quad\quad\quad + \mathbf{x}_{ij} \boldsymbol\gamma + e_{ij}, \end{aligned} \] where \(\mathbf{x}_{ij}\) is a row vector of student characteristics, included just to make the regression look fancier. In this specification, \(\beta_3\) and \(\beta_4\) represent the effects of being in a small class or aide class, compared to being in a regular class, but only for the reference level of urbanicity—in this case, urban schools. The coefficients \(\beta_5, \beta_6, \beta_7, \beta_8\) all represent interactions between treatment condition and urbanicity. Here’s the model, estimated in R:

lm_urbanicity <- lm(math1 ~ schoolk * stark + gender + ethnicity + lunchk, data = STAR)
V_urbanicity <- vcovCR(lm_urbanicity, cluster = STAR$schoolidk, type = "CR2")
coef_test(lm_urbanicity, vcov = V_urbanicity)
##                       Coef. Estimate    SE  t-stat d.f. (Satt) p-val (Satt)
##                 (Intercept)   542.62  5.91 91.8599       21.70       <0.001
##             schoolksuburban     2.77  6.76  0.4100       28.35       0.6849
##                schoolkrural     1.03  6.38  0.1616       30.74       0.8727
##                  starksmall     9.42  4.56  2.0649       17.10       0.0544
##                   starkaide    -4.27  2.17 -1.9631       16.73       0.0665
##                genderfemale     2.14  1.20  1.7773       67.14       0.0800
##               ethnicityafam   -16.79  4.19 -4.0026       34.94       <0.001
##              ethnicityasian    13.19 11.02  1.1963        6.23       0.2751
##           ethnicityhispanic    39.23 20.62  1.9028        1.01       0.3067
##              ethnicityother     8.86 18.78  0.4720        3.02       0.6690
##                  lunchkfree   -19.37  2.04 -9.4848       57.38       <0.001
##  schoolksuburban:starksmall     3.03  6.39  0.4746       28.94       0.6386
##     schoolkrural:starksmall    -0.31  5.58 -0.0555       34.04       0.9560
##   schoolksuburban:starkaide     5.10  3.72  1.3711       28.64       0.1810
##      schoolkrural:starkaide     8.16  3.16  2.5857       34.30       0.0141
##  Sig.
##   ***
##      
##      
##     .
##     .
##     .
##   ***
##      
##      
##      
##   ***
##      
##      
##      
##     *

With this specification, there are several different null hypotheses that we might want to test. For one, perhaps we want to see if there is any variation in treatment effects across different levels of urbanicity. This can be expressed in the null hypothesis that all four interaction terms are zero, or \(H_{0A}: \beta_5 = \beta_6 = \beta_7 = \beta_8 = 0\). With Wald test:

Wald_test(lm_urbanicity, 
          constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE),
          vcov = V_urbanicity)
##  test Fstat df_num df_denom p_val sig
##   HTZ  1.96      4     37.5 0.121

Another possibility is that we might want to focus on variation in the effect of being in a small class or regular class, while ignoring whatever is going on in the aide class condition. Here, the null hypothesis would be simply \(H_{0B}: \beta_5 = \beta_6 = 0\), tested as:

Wald_test(lm_urbanicity, 
          constraints = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE),
          vcov = V_urbanicity)
##  test Fstat df_num df_denom p_val sig
##   HTZ 0.189      2     34.5 0.828

2.1 Lists of constraints

In models like the urbanicity-by-treatment interaction specification, we may need to run multiple tests on the same estimating equation. This can be accomplished with Wald_test by providing a list of constraints to the constraints argument. For example, we could test the hypotheses described above by creating a list of several constraint matrices and then passing it to Wald_test:

C_list <- list(
  `Any interaction` = constrain_zero("schoolk.+:stark", 
                                     coef(lm_urbanicity), reg_ex = TRUE),
  `Small vs regular` = constrain_zero("schoolk.+:starksmall", 
                                      coef(lm_urbanicity), reg_ex = TRUE)
)

Wald_test(lm_urbanicity, 
          constraints = C_list,
          vcov = V_urbanicity)
## $`Any interaction`
##  test Fstat df_num df_denom p_val sig
##   HTZ  1.96      4     37.5 0.121    
## 
## $`Small vs regular`
##  test Fstat df_num df_denom p_val sig
##   HTZ 0.189      2     34.5 0.828

Setting the option tidy = TRUE will arrange the output of all the tests into a single data frame:

Wald_test(lm_urbanicity, 
          constraints = C_list,
          vcov = V_urbanicity, 
          tidy = TRUE)
##        hypothesis test Fstat df_num df_denom p_val sig
##   Any interaction  HTZ 1.960      4     37.5 0.121    
##  Small vs regular  HTZ 0.189      2     34.5 0.828

The list of constraints can also be created inside Wald_test, so that the coefs argument can be omitted from constrain_zero():

Wald_test(
  lm_urbanicity, 
  constraints = list(
    `Any interaction` = constrain_zero("schoolk.+:stark", reg_ex = TRUE),
    `Small vs regular` = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE)
  ),
  vcov = V_urbanicity, 
  tidy = TRUE
)
##        hypothesis test Fstat df_num df_denom p_val sig
##   Any interaction  HTZ 1.960      4     37.5 0.121    
##  Small vs regular  HTZ 0.189      2     34.5 0.828

3 Pairwise t-tests

The clubSandwich package also provides a further convenience function, constrain_pairwise() that can be used in combination with Wald_test() to conduct pairwise comparisons among a set of regression coefficients. This function differs from the other two constrain_*() functions because it returns a list of constraint matrices, each of which corresponds to a single linear combination of covariates. Specifically, the constrain_pairwise() function provides a list of constraints that represent the differences between every possible pair among a specified set of coefficients. The syntax is very similar to the other constrain_*() functions.

To demonstrate, consider the separate-intercepts specification of the simpler regression model:

coef_test(lm_sep, vcov = V_sep)
##         Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##  starkregular      532 2.78    192        59.9       <0.001  ***
##    starksmall      541 2.89    187        65.0       <0.001  ***
##     starkaide      531 2.72    195        64.3       <0.001  ***

This specification is nice because it lets us simply read off the average outcomes for each group. However, we will naturally also want to know about whether there are differences between the groups, so we’ll want to compare the small-class condition to the regular-size class condition, the aide condition to the regular-size class condition, and the small-class condition to the aide condition. Thus, we’ll want comparisons among all three coefficients:

C_pairs <- constrain_pairwise(1:3, coefs = coef(lm_sep))
C_pairs
## $`starksmall - starkregular`
##      [,1] [,2] [,3]
## [1,]   -1    1    0
## 
## $`starkaide - starkregular`
##      [,1] [,2] [,3]
## [1,]   -1    0    1
## 
## $`starkaide - starksmall`
##      [,1] [,2] [,3]
## [1,]    0   -1    1

Feeding these constraints into Wald_test() gives us significance tests for each pair:

Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE)
##                 hypothesis test   Fstat df_num df_denom  p_val sig
##  starksmall - starkregular  HTZ 16.9238      1     65.6 <0.001 ***
##   starkaide - starkregular  HTZ  0.0673      1     65.6  0.796    
##     starkaide - starksmall  HTZ 17.8137      1     66.9 <0.001 ***

The first two of these tests are equivalent to the tests of the treatment effect coefficients in the other parameterization of the model. Indeed, the denominator degrees of freedom are identical to the results of coef_test(lm_trt, vcov = V_trt); the Fstats here are equal to the squared t-statistics from the first model:

t_stats <- coef_test(lm_trt, vcov = V_trt)$tstat[2:3]
F_stats <- Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE)$Fstat[1:2]
all.equal(t_stats^2, F_stats)
## [1] TRUE

It is important to note that the p-values from the pairwise comparisons are not corrected for multiplicity.3 For now, please correct-your-own using p.adjust() or your preferred method.

Pairwise comparisons might also be of use in the model with treatment-by-urbanicity interactions. Here’s the model results again:

coef_test(lm_urbanicity, vcov = V_urbanicity)
##                       Coef. Estimate    SE  t-stat d.f. (Satt) p-val (Satt)
##                 (Intercept)   542.62  5.91 91.8599       21.70       <0.001
##             schoolksuburban     2.77  6.76  0.4100       28.35       0.6849
##                schoolkrural     1.03  6.38  0.1616       30.74       0.8727
##                  starksmall     9.42  4.56  2.0649       17.10       0.0544
##                   starkaide    -4.27  2.17 -1.9631       16.73       0.0665
##                genderfemale     2.14  1.20  1.7773       67.14       0.0800
##               ethnicityafam   -16.79  4.19 -4.0026       34.94       <0.001
##              ethnicityasian    13.19 11.02  1.1963        6.23       0.2751
##           ethnicityhispanic    39.23 20.62  1.9028        1.01       0.3067
##              ethnicityother     8.86 18.78  0.4720        3.02       0.6690
##                  lunchkfree   -19.37  2.04 -9.4848       57.38       <0.001
##  schoolksuburban:starksmall     3.03  6.39  0.4746       28.94       0.6386
##     schoolkrural:starksmall    -0.31  5.58 -0.0555       34.04       0.9560
##   schoolksuburban:starkaide     5.10  3.72  1.3711       28.64       0.1810
##      schoolkrural:starkaide     8.16  3.16  2.5857       34.30       0.0141
##  Sig.
##   ***
##      
##      
##     .
##     .
##     .
##   ***
##      
##      
##      
##   ***
##      
##      
##      
##     *

Suppose that we are interested in the effect of small versus regular size classes, and in particular whether this effect varies across schools in different areas. The coefficients on schoolksuburban:starksmall and schoolkrural:starksmall already give us the differences in treatment effects between suburban schools versus urban schools and between rural schools versus urban schools. The difference between these coefficients gives us the difference in treatment effects between suburban schools and rural schools. We can look at all three of these contrasts using constrain_pairwise() by setting the option with_zero = TRUE:

Wald_test(lm_urbanicity, 
          constraints = constrain_pairwise(":starksmall", reg_ex = TRUE, with_zero = TRUE),
          vcov = V_urbanicity,
          tidy = TRUE)
##                                            hypothesis test   Fstat df_num
##                            schoolksuburban:starksmall  HTZ 0.22526      1
##                               schoolkrural:starksmall  HTZ 0.00308      1
##  schoolkrural:starksmall - schoolksuburban:starksmall  HTZ 0.36471      1
##  df_denom p_val sig
##      28.9 0.639    
##      34.0 0.956    
##      24.4 0.551

Again, the results of the first two tests are identical to the t-tests reported in coef_test().

4 Remark

All of the preceding examples were based on ordinary linear regression models with clustered standard errors. However, Wald_test() and its helper functions all work identically for all of the other models with supporting clubSandwich methods, including nlme::lme(), nlme::gls(), lme4::lmer(), rma.uni(), rma.mv(), and robu(), among others.

References

Pustejovsky, J. E., & Tipton, E. (2018). Small-Sample Methods for Cluster-Robust Variance Estimation and Hypothesis Testing in Fixed Effects Models. Journal of Business & Economic Statistics, 36(4), 672–683. https://doi.org/10.1080/07350015.2016.1247004
Tipton, E., & Pustejovsky, J. E. (2015). Small-sample adjustments for tests of moderators and model fit using robust variance estimation in meta-regression. Journal of Educational and Behavioral Statistics, 40(6), 604–634. https://doi.org/10.3102/1076998615606099

  1. In Pustejovsky & Tipton (2018) we used a more general formulation of multiple-constraint null hypotheses, expressed as \(H_0: \mathbf{C} \boldsymbol\beta = \mathbf{d}\) for some fixed \(q \times 1\) vector \(\mathbf{d}\). In practice, it’s often possible to modify the \(\mathbf{C}\) matrix so that \(\mathbf{d}\) can always be set to \(\mathbf{0}\).↩︎

  2. How does this work? If we omit the coefs argument, constrain_zero() acts as a functional, by returning a function equivalent to function(coefs) constrain_zero(constraints, coefs = coefs). If this function is fed into the constraints argument of Wald_test(), Wald_test() recognizes that it is a function and evaluates the function with coef(obj). It’s a kinda-sorta hacky substitute for lazy evaluation. If you have suggestions for how to do this more elegantly, please send them my way.↩︎

  3. Options to include multiplicity corrections (Bonferroni, Holm, Benjamini-Hochberg, etc.) might be included in a future release. Reach out if this is of interest to you.↩︎

clubSandwich/inst/doc/panel-data-CRVE.Rmd0000644000176200001440000003660414630154052017622 0ustar liggesusers--- title: "Cluster-robust standard errors and hypothesis tests in panel data models" author: "James E. Pustejovsky" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Cluster-robust standard errors and hypothesis tests in panel data models} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- The importance of using cluster-robust variance estimators (i.e., "clustered standard errors") in panel models is now widely recognized. Less widely recognized is the fact that standard methods for constructing hypothesis tests and confidence intervals based on CRVE can perform quite poorly in when based on a limited number of independent clusters. Furthermore, it can be difficult to determine what counts as a large-enough sample to trust standard CRVE methods, because the finite-sample behavior of the variance estimators and test statistics depends on the configuration of the covariates, not just the total number of clusters. One solution to this problem is to use bias-reduced linearization (BRL), which was proposed by Bell and McCaffrey (2002) and has recently begun to receive attention in the econometrics literature (e.g., Cameron & Miller, 2015; Imbens & Kolesar, 2015). The idea of BRL is to correct the bias of standard CRVE based on a working model, and then to use a degrees-of-freedom correction for Wald tests based on the bias-reduced CRVE. That may seem silly (after all, the whole point of CRVE is to avoid making distributional assumptions about the errors in your model), but it turns out that the correction can help quite a bit, even when the working model is wrong. The degrees-of-freedom correction is based on a standard Satterthwaite-type approximation, and also relies on the working model. A problem with Bell and McCaffrey's original formulation of BRL is that it does not work in some very common models for panel data, such as state-by-year panels that include fixed effects for each state and each year (Angrist and Pischke, 2009, point out this issue in their chapter on "non-standard standard error issues"; see also Young, 2016). However, Pustejovsky and Tipton (2016) proposed a generalization of BRL that works even in models with arbitrary sets of fixed effects, and this generalization is implemented in `clubSandwich` as CRVE type `CR2`. The package also implements small-sample corrections for multiple-constraint hypothesis tests based on an approximation proposed by Pustejovsky and Tipton (2016). For one-parameter constraints, the test reduces to a t-test with Satterthwaite degrees of freedom, and so it is a natural extension of BRL. The following example demonstrates how to use `clubSandwich` to do cluster-robust inference for a state-by-year panel model with fixed effects in both dimensions, clustering by states. ## Effects of changing the minimum legal drinking age Carpenter and Dobkin (2011) analyzed the effects of changes in the minimum legal drinking age on rates of motor vehicle fatalities among 18-20 year olds, using state-level panel data from the National Highway Traffic Administration's Fatal Accident Reporting System. In their new textbook, Angrist and Pischke (2014) developed a stylized example based on Carpenter and Dobkin's work. The following example uses Angrist and Pischke's data and follows their analysis because their data are [easily available](https://www.masteringmetrics.com/resources/). The outcome is the incidence of deaths in motor vehicle crashes among 18-20 year-olds (per 100,000 residents), for each state plus the District of Columbia, over the period 1970 to 1983. There were several changes in the minimum legal drinking age during this time period, with variability in the timing of changes across states. Angrist and Pischke (following Carpenter and Dobkin) use a difference-in-differences strategy to estimate the effects of lowering the minimum legal drinking age from 21 to 18. Their specification is $$y_{it} = \alpha_i + \beta_t + \gamma b_{it} + \delta d_{it} + \epsilon_{it},$$ for $i$ = 1,...,51 and $t$ = 1970,...,1983. In this model, $\alpha_i$ is a state-specific fixed effect, $\beta_t$ is a year-specific fixed effect, $b_{it}$ is the current rate of beer taxation in state $i$ in year $t$, $d_{it}$ is the proportion of 18-20 year-olds in state $i$ in year $t$ who are legally allowed to drink, and $\delta$ captures the effect of shifting the minimum legal drinking age from 21 to 18. Following Angrist and Pischke's analysis, we estimate this model both by (unweighted) OLS and by weighted least squares with weights corresponding to population size in a given state and year. We also demonstrate random effects estimation and implement a cluster-robust Hausman specification test. ## Unweighted OLS The following code does some simple data-munging and the estimates the model by OLS: ```{r, message = FALSE, warning = FALSE} library(clubSandwich) data(MortalityRates) # subset for deaths in motor vehicle accidents, 1970-1983 MV_deaths <- subset(MortalityRates, cause=="Motor Vehicle" & year <= 1983 & !is.na(beertaxa)) # fit by OLS lm_unweighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), data = MV_deaths) ``` The `coef_test` function from `clubSandwich` can then be used to test the hypothesis that changing the minimum legal drinking age has no effect on motor vehicle deaths in this cohort (i.e., $H_0: \delta = 0$). The usual way to test this is to cluster the standard errors by state, calculate the robust Wald statistic, and compare that to a standard normal reference distribution. The code and results are as follows: ```{r} coef_test(lm_unweighted, vcov = "CR1", cluster = MV_deaths$state, test = "naive-t")[1:2,] ``` A better approach would be to use the generalized, bias-reduced linearization CRVE, together with Satterthwaite degrees of freedom. In the `clubSandwich` package, the BRL adjustment is called "CR2" because it is directly analogous to the HC2 correction used in heteroskedasticity-robust variance estimation. When applied to an OLS model estimated by `lm`, the default working model is an identity matrix, which amounts to the "working" assumption that the errors are all uncorrelated and homoskedastic. Here's how to apply this approach in the example: ```{r} coef_test(lm_unweighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")[1:2,] ``` The Satterthwaite degrees of freedom are different for each coefficient in the model, and so the `coef_test` function reports them right alongside the standard error. For the effect of legal drinking age, the degrees of freedom are about half of what might be expected, given that there are 51 clusters. The p-value for the CR2+Satterthwaite test is about twice as large as the p-value based on the standard Wald test, although the coefficient is still statistically significant at conventional levels. Note, however, that the degrees of freedom on the beer taxation rate are considerably smaller because there are only a few states with substantial variability in taxation rates over time. ```{r, echo = FALSE, results = "asis"} plm_available <- requireNamespace("plm", quietly = TRUE) if (!plm_available) cat("## Building the remainder of the vignette requires the plm package. Please install it. {-}") ``` ## Unweighted "within" estimation The `plm` package in R provides another way to estimate the same model. It is convenient because it absorbs the state and year fixed effects before estimating the effect of `legal`. The `clubSandwich` package works with fitted `plm` models too: ```{r, message = FALSE, eval = plm_available} library(plm) plm_unweighted <- plm(mrate ~ legal + beertaxa, data = MV_deaths, effect = "twoways", index = c("state","year")) coef_test(plm_unweighted, vcov = "CR1", cluster = "individual", test = "naive-t") coef_test(plm_unweighted, vcov = "CR2", cluster = "individual", test = "Satterthwaite") ``` ## Population-weighted estimation The difference between the standard method and the new method are not terribly exciting in the above example. However, things change quite a bit if the model is estimated using population weights. We go back to fitting in `lm` with dummies for all the fixed effects because `plm` does not handle weighted least squares. ```{r} lm_weighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), weights = pop, data = MV_deaths) coef_test(lm_weighted, vcov = "CR1", cluster = MV_deaths$state, test = "naive-t")[1:2,] coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")[1:2,] ``` Using population weights slightly reduces the point estimate of the effect, while also slightly increasing its precision. If you were following the standard approach, you would probably be happy with the weighted estimates and wouldn't think about it any further. However, using the CR2 variance estimator and Satterthwaite correction produces a p-value that is an order of magnitude larger (though still significant at the conventional 5% level). The degrees of freedom are just `r round(coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")["legal","df_Satt"], 1)`---drastically smaller than would be expected based on the number of clusters. Even with weights, the `coef_test` function uses an "independent, homoskedastic" working model as a default for `lm` objects. In the present example, the outcome is a standardized rate and so a better assumption might be that the error variances are inversely proportional to population size. The following code uses this alternate working model: ```{r} coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, target = 1 / MV_deaths$pop, test = "Satterthwaite")[1:2,] ``` The new working model leads to slightly smaller standard errors and a couple of additional degrees of freedom, though they remain in small-sample territory. ## Random effects estimation If the unobserved effects $\alpha_1,...,\alpha_{51}$ are uncorrelated with the regressors, then a more efficient way to estimate $\gamma,\delta$ is by weighted least squares, with weights based on a random effects model. We still treat the year effects as fixed. ```{r, eval = plm_available} plm_random <- plm(mrate ~ 0 + legal + beertaxa + year, data = MV_deaths, effect = "individual", index = c("state","year"), model = "random") coef_test(plm_random, vcov = "CR1", test = "naive-t")[1:2,] coef_test(plm_random, vcov = "CR2", test = "Satterthwaite")[1:2,] ``` With random effects estimation, the effect of legal drinking age is smaller by about 1 death per 100,000. As a procedural aside, note that `coef_test` infers that `state` is the clustering variable because the call to plm includes only one type of effects (random state effects). ## Robust Hausman test CRVE is also used in specification tests, as in the artificial Hausman-type test for endogeneity of unobserved effects (Arellano, 1993). As noted above, random effects estimation is more efficient than fixed effects estimation, but requires the assumption that the unobserved effects are uncorrelated with the regressors. However, if the unobserved effects covary with $\mathbf{b}_i, \mathbf{d}_i$, then the random-effects estimator will be biased. We can test for whether endogeneity is a problem by including group-centered covariates as additional regressors. Let $\tilde{d}_{it} = d_{it} - \frac{1}{T}\sum_t d_{it}$, with $\tilde{b}_{it}$ defined analogously. Now estimate the regression $$y_{it} = \beta_t + \gamma_1 b_{it} + \gamma_2 \tilde{b}_{it} + \delta_1 d_{it} + \delta_2 \tilde{d}_{it} + \epsilon_{it},$$ which does not include state fixed effects. The parameters $\gamma_2,\delta_2$ represent the differences between the within-groups and between-groups estimands of $\gamma_1, \delta_1$. If these are both zero, then the random effects estimator is unbiased. Thus, the joint test for $H_0: \gamma_2 = \delta_2 = 0$ amounts to a test for exogeneity of the unobserved effects. For efficiency, we estimate this specification using weighted least squares (although OLS would be valid too): ```{r, eval = plm_available} MV_deaths <- within(MV_deaths, { legal_cent <- legal - tapply(legal, state, mean)[factor(state)] beer_cent <- beertaxa - tapply(beertaxa, state, mean)[factor(state)] }) plm_Hausman <- plm(mrate ~ 0 + legal + beertaxa + legal_cent + beer_cent + factor(year), data = MV_deaths, effect = "individual", index = c("state","year"), model = "random") coef_test(plm_Hausman, vcov = "CR2", test = "Satterthwaite")[1:4,] ``` To conduct a joint test on the centered covariates, we can use the `Wald_test` function. The usual way to test this hypothesis would be to use the `CR1` variance estimator to calculate the robust Wald statistic, then use a $\chi^2_2$ reference distribution (or equivalently, compare a re-scaled Wald statistic to an $F(2,\infty)$ distribution). The `Wald_test` function reports the latter version: ```{r, eval = plm_available} Wald_test(plm_Hausman, constraints = constrain_zero(c("legal_cent","beer_cent")), vcov = "CR1", test = "chi-sq") ``` The test is just shy of significance at the 5% level. If we instead use the `CR2` variance estimator and our newly proposed approximate F-test (which is the default in `Wald_test`), then we get: ```{r, eval = plm_available} Wald_test(plm_Hausman, constraints = constrain_zero(c("legal_cent","beer_cent")), vcov = "CR2") ``` The low degrees of freedom of the test indicate that we're definitely in small-sample territory and should not trust the asymptotic $\chi^2$ approximation. ## References Angrist, J. D., & Pischke, J. (2009). _Mostly harmless econometrics: An empiricist’s companion_. Princeton, NJ: Princeton University Press. Angrist, J. D., and Pischke, J. S. (2014). _Mastering'metrics: the path from cause to effect_. Princeton, NJ: Princeton University Press. Arellano, M. (1993). On the testing of correlated effects with panel data. Journal of Econometrics, 59(1-2), 87-97. doi: [10.1016/0304-4076(93)90040-C](https://www.sciencedirect.com/science/article/pii/030440769390040C) Bell, R. M., & McCaffrey, D. F. (2002). Bias reduction in standard errors for linear regression with multi-stage samples. _Survey Methodology, 28_(2), 169-181. Cameron, A. C., & Miller, D. L. (2015). A practitioner’s guide to cluster-robust inference. URL: https://cameron.econ.ucdavis.edu/research/Cameron_Miller_JHR_2015_February.pdf Carpenter, C., & Dobkin, C. (2011). The minimum legal drinking age and public health. _Journal of Economic Perspectives, 25_(2), 133-156. doi: [10.1257/jep.25.2.133](https://doi.org/10.1257/jep.25.2.133) Imbens, G. W., & Kolesar, M. (2015). Robust standard errors in small samples: Some practical advice. URL: https://doi.org/10.1162/REST_a_00552 Pustejovsky, J. E. & Tipton, E. (2016). Small sample methods for cluster-robust variance estimation and hypothesis testing in fixed effects models. arXiv: [1601.01981](https://arxiv.org/abs/1601.01981) [stat.ME] Young, A. (2016). Improved, nearly exact, statistical inference with robust and clustered covariance matrices using effective degrees of freedom corrections. clubSandwich/inst/doc/meta-analysis-with-CRVE.html0000644000176200001440000007062614635065006021565 0ustar liggesusers Meta-analysis with cluster-robust variance estimation

Meta-analysis with cluster-robust variance estimation

James E. Pustejovsky

2024-06-20

This vignette demonstrates how to use the clubSandwich package to conduct a meta-analysis of dependent effect sizes with robust variance estimation. Tests of meta-regression coefficients and F-tests of multiple-coefficient hypotheses are calculated using small-sample corrections proposed by Tipton (2015) and Tipton and Pustejovsky (2015). The example uses a dataset of effect sizes from a Campbell Collaboration systematic review of dropout prevention programs, conducted by Sandra Jo Wilson and colleagues (2011).

The original analysis included a meta-regression with covariates that capture methodological, participant, and program characteristics. The regression specification used here is similar to Model III from Wilson et al. (2011), but treats the evaluator_independence and implementation_quality variables as categorical rather than interval-level. Also, the original analysis clustered at the level of the sample (some studies reported results from multiple samples), whereas here we cluster at the study level. The meta-regression can be fit in several different ways. We first demonstrate using the robumeta package (Fisher & Tipton, 2015) and then using the metafor package (Viechtbauer, 2010).

robumeta model

library(clubSandwich)
library(robumeta)
data(dropoutPrevention)

# clean formatting
names(dropoutPrevention)[7:8] <- c("eval","implement")
levels(dropoutPrevention$eval) <- c("independent","indirect","planning","delivery")
levels(dropoutPrevention$implement) <- c("low","medium","high")
levels(dropoutPrevention$program_site) <- c("community","mixed","classroom","school")
levels(dropoutPrevention$study_design) <- c("matched","unmatched","RCT")
levels(dropoutPrevention$adjusted) <- c("no","yes")

m3_robu <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted
                + outcome + eval + male_pct + white_pct + average_age
                + implement + program_site + duration + service_hrs, 
                data = dropoutPrevention, studynum = studyID, var.eff.size = varLOR, 
                modelweights = "HIER")
print(m3_robu)
## RVE: Hierarchical Effects Model with Small-Sample Corrections 
## 
## Model: LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs 
## 
## Number of clusters = 152 
## Number of outcomes = 385 (min = 1 , mean = 2.53 , median = 1 , max = 30 )
## Omega.sq = 0.24907 
## Tau.sq = 0.1024663 
## 
##                           Estimate   StdErr t-value  dfs    P(|t|>) 95% CI.L 95% CI.U Sig
## 1           X.Intercept.  0.016899 0.615399  0.0275 16.9 0.97841541 -1.28228  1.31608    
## 2  study_designunmatched -0.002626 0.185142 -0.0142 40.5 0.98875129 -0.37667  0.37141    
## 3        study_designRCT -0.086872 0.140044 -0.6203 38.6 0.53869676 -0.37024  0.19650    
## 4              attrition  0.118889 0.247228  0.4809 15.5 0.63732597 -0.40666  0.64444    
## 5      group_equivalence  0.502463 0.195838  2.5657 28.7 0.01579282  0.10174  0.90318  **
## 6            adjustedyes -0.322480 0.125413 -2.5713 33.8 0.01470796 -0.57741 -0.06755  **
## 7        outcomeenrolled  0.097059 0.139842  0.6941 16.5 0.49727848 -0.19862  0.39274    
## 8      outcomegraduation  0.147643 0.134938  1.0942 30.2 0.28253825 -0.12786  0.42315    
## 9  outcomegraduation.ged  0.258034 0.169134  1.5256 16.3 0.14632629 -0.10006  0.61613    
## 10          evalindirect -0.765085 0.399109 -1.9170  6.2 0.10212896 -1.73406  0.20389    
## 11          evalplanning -0.920874 0.346536 -2.6574  5.6 0.04027061 -1.78381 -0.05794  **
## 12          evaldelivery -0.916673 0.304303 -3.0124  4.7 0.03212299 -1.71432 -0.11903  **
## 13              male_pct  0.167965 0.181538  0.9252 16.4 0.36824526 -0.21609  0.55202    
## 14             white_pct  0.022915 0.149394  0.1534 21.8 0.87950385 -0.28704  0.33287    
## 15           average_age  0.037102 0.027053  1.3715 21.2 0.18458247 -0.01913  0.09333    
## 16       implementmedium  0.411779 0.128898  3.1946 26.7 0.00358205  0.14714  0.67642 ***
## 17         implementhigh  0.658570 0.123874  5.3164 34.6 0.00000635  0.40699  0.91015 ***
## 18     program_sitemixed  0.444384 0.172635  2.5741 28.6 0.01550504  0.09109  0.79768  **
## 19 program_siteclassroom  0.426658 0.159773  2.6704 37.4 0.01115192  0.10303  0.75028  **
## 20    program_siteschool  0.262517 0.160519  1.6354 30.1 0.11236814 -0.06525  0.59028    
## 21              duration  0.000427 0.000873  0.4895 36.7 0.62736846 -0.00134  0.00220    
## 22           service_hrs -0.003434 0.005012 -0.6852 36.7 0.49752503 -0.01359  0.00672    
## ---
## Signif. codes: < .01 *** < .05 ** < .10 *
## ---
## Note: If df < 4, do not trust the results

Note that robumeta produces small-sample corrected standard errors and t-tests, and so there is no need to repeat those calculations with clubSandwich. The eval variable has four levels, and it might be of interest to test whether the average program effects differ by the degree of evaluator independence. The null hypothesis in this case is that the 10th, 11th, and 12th regression coefficients are all equal to zero. A small-sample adjusted F-test for this hypothesis can be obtained as follows. The vcov = "CR2" option means that the standard errors will be corrected using the bias-reduced linearization estimator described in Tipton and Pustejovsky (2015).

Wald_test(m3_robu, constraints = constrain_zero(10:12), vcov = "CR2")
##  test Fstat df_num df_denom  p_val sig
##   HTZ  2.78      3     16.8 0.0732   .

By default, the Wald_test function provides an F-type test with degrees of freedom estimated using the approximate Hotelling’s \(T^2_Z\) method. The test has less than 17 degrees of freedom, even though there are 152 independent studies in the data, and has a p-value that is not quite significant at conventional levels. The low degrees of freedom are a consequence of the fact that one of the levels of evaluator independence has only a few effect sizes in it:

table(dropoutPrevention$eval)
## 
## independent    indirect    planning    delivery 
##           6          33          43         303

metafor model

clubSandwich also works with models fit using the metafor package. Here we re-fit the same regression specification, but use REML to estimate the variance components (robumeta uses a method-of-moments estimator), as well as a somewhat different weighting scheme than that used in robumeta.

library(metafor)
m3_metafor <- rma.mv(LOR1 ~ study_design + attrition + group_equivalence + adjusted
                      + outcome + eval
                      + male_pct + white_pct + average_age
                      + implement + program_site + duration + service_hrs, 
                      V = varLOR, random = list(~ 1 | studyID, ~ 1 | studySample),
                     data = dropoutPrevention)
summary(m3_metafor)
## 
## Multivariate Meta-Analysis Model (k = 385; method: REML)
## 
##    logLik   Deviance        AIC        BIC       AICc   
## -489.0357   978.0714  1026.0714  1119.5371  1029.6217   
## 
## Variance Components:
## 
##             estim    sqrt  nlvls  fixed       factor 
## sigma^2.1  0.2274  0.4769    152     no      studyID 
## sigma^2.2  0.1145  0.3384    317     no  studySample 
## 
## Test for Residual Heterogeneity:
## QE(df = 363) = 1588.4397, p-val < .0001
## 
## Test of Moderators (coefficients 2:22):
## QM(df = 21) = 293.8694, p-val < .0001
## 
## Model Results:
## 
##                        estimate      se     zval    pval    ci.lb    ci.ub      
## intrcpt                  0.5296  0.7250   0.7304  0.4651  -0.8915   1.9506      
## study_designunmatched   -0.0494  0.1722  -0.2871  0.7741  -0.3870   0.2881      
## study_designRCT          0.0653  0.1628   0.4010  0.6884  -0.2538   0.3843      
## attrition               -0.1366  0.2429  -0.5623  0.5739  -0.6126   0.3395      
## group_equivalence        0.4071  0.1573   2.5877  0.0097   0.0988   0.7155   ** 
## adjustedyes             -0.3581  0.1532  -2.3371  0.0194  -0.6585  -0.0578    * 
## outcomeenrolled         -0.2831  0.0771  -3.6709  0.0002  -0.4343  -0.1320  *** 
## outcomegraduation       -0.0913  0.0657  -1.3896  0.1646  -0.2201   0.0375      
## outcomegraduation/ged    0.6983  0.0805   8.6750  <.0001   0.5406   0.8561  *** 
## evalindirect            -0.7530  0.4949  -1.5214  0.1282  -1.7230   0.2171      
## evalplanning            -0.7700  0.4869  -1.5814  0.1138  -1.7242   0.1843      
## evaldelivery            -1.0016  0.4600  -2.1774  0.0294  -1.9033  -0.1000    * 
## male_pct                 0.1021  0.1715   0.5951  0.5518  -0.2341   0.4382      
## white_pct                0.1223  0.1804   0.6777  0.4979  -0.2313   0.4758      
## average_age              0.0061  0.0291   0.2091  0.8344  -0.0509   0.0631      
## implementmedium          0.4738  0.1609   2.9445  0.0032   0.1584   0.7892   ** 
## implementhigh            0.6318  0.1471   4.2965  <.0001   0.3436   0.9201  *** 
## program_sitemixed        0.3289  0.2413   1.3631  0.1729  -0.1440   0.8019      
## program_siteclassroom    0.2920  0.1736   1.6821  0.0926  -0.0482   0.6321    . 
## program_siteschool       0.1616  0.1898   0.8515  0.3945  -0.2104   0.5337      
## duration                 0.0013  0.0009   1.3423  0.1795  -0.0006   0.0031      
## service_hrs             -0.0003  0.0047  -0.0654  0.9478  -0.0096   0.0090      
## 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

metafor produces model-based standard errors, t-tests, and confidence intervals. The coef_test function from clubSandwich will calculate robust standard errors and robust t-tests for each of the coefficients:

coef_test(m3_metafor, vcov = "CR2")
##                  Coef.  Estimate       SE  t-stat d.f. (Satt) p-val (Satt) Sig.
##                intrcpt  0.529569 0.724851  0.7306       20.08      0.47347     
##  study_designunmatched -0.049434 0.204152 -0.2421       58.42      0.80952     
##        study_designRCT  0.065272 0.149146  0.4376       53.17      0.66342     
##              attrition -0.136575 0.306429 -0.4457       10.52      0.66485     
##      group_equivalence  0.407108 0.210917  1.9302       23.10      0.06595    .
##            adjustedyes -0.358124 0.136132 -2.6307       43.20      0.01176    *
##        outcomeenrolled -0.283124 0.237199 -1.1936        7.08      0.27108     
##      outcomegraduation -0.091295 0.091465 -0.9981        9.95      0.34188     
##  outcomegraduation/ged  0.698328 0.364882  1.9138        8.02      0.09188    .
##           evalindirect -0.752994 0.447670 -1.6820        6.56      0.13929     
##           evalplanning -0.769968 0.403898 -1.9063        6.10      0.10446     
##           evaldelivery -1.001648 0.355989 -2.8137        4.89      0.03834    *
##               male_pct  0.102055 0.148410  0.6877        9.68      0.50782     
##              white_pct  0.122255 0.141470  0.8642       16.88      0.39961     
##            average_age  0.006084 0.033387  0.1822       15.79      0.85772     
##        implementmedium  0.473789 0.148660  3.1871       22.44      0.00419   **
##          implementhigh  0.631842 0.138073  4.5761       28.68      < 0.001  ***
##      program_sitemixed  0.328941 0.196848  1.6710       27.47      0.10607     
##  program_siteclassroom  0.291952 0.146014  1.9995       42.70      0.05195    .
##     program_siteschool  0.161640 0.171700  0.9414       29.27      0.35420     
##               duration  0.001270 0.000978  1.2988       31.96      0.20332     
##            service_hrs -0.000309 0.004828 -0.0641       49.63      0.94915

Note that coef_test assumed that it should cluster based on studyID, which is the outer-most random effect in the metafor model. This can be specified explicitly by including the option cluster = dropoutPrevention$studyID in the call.

The F-test for degree of evaluator independence uses the same syntax as before:

Wald_test(m3_metafor, constraints = constrain_zero(10:12), vcov = "CR2")
##  test Fstat df_num df_denom  p_val sig
##   HTZ  2.71      3     18.3 0.0753   .

Despite some differences in weighting schemes, the p-value is very close to the result obtained using robumeta.

References

Fisher, Z., & Tipton, E. (2015). robumeta: An R-package for robust variance estimation in meta-analysis. arXiv:1503.02220

Tipton, E. (2015). Small sample adjustments for robust variance estimation with meta-regression. Psychological Methods, 20(3), 375-393. https://doi.org/10.1037/met0000011

Tipton, E., & Pustejovsky, J. E. (2015). Small-sample adjustments for tests of moderators and model fit using robust variance estimation in meta-regression. Journal of Educational and Behavioral Statistics, 40(6), 604-634. https://doi.org/10.3102/1076998615606099

Viechtbauer, W. (2010). Conducting meta-analyses in R with the metafor package. Journal of Statistical Software, 36(3), 1-48. URL: https://doi.org/10.18637/jss.v036.i03

Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: Effects on school completion and dropout Among school-aged children and youth: A systematic review. Campbell Systematic Reviews, 7(1), 1-61. https://doi.org/10.4073/csr.2011.8

clubSandwich/inst/doc/panel-data-CRVE.R0000644000176200001440000000726214635065007017305 0ustar liggesusers## ----message = FALSE, warning = FALSE------------------------------------------------------------- library(clubSandwich) data(MortalityRates) # subset for deaths in motor vehicle accidents, 1970-1983 MV_deaths <- subset(MortalityRates, cause=="Motor Vehicle" & year <= 1983 & !is.na(beertaxa)) # fit by OLS lm_unweighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), data = MV_deaths) ## ------------------------------------------------------------------------------------------------- coef_test(lm_unweighted, vcov = "CR1", cluster = MV_deaths$state, test = "naive-t")[1:2,] ## ------------------------------------------------------------------------------------------------- coef_test(lm_unweighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")[1:2,] ## ----echo = FALSE, results = "asis"--------------------------------------------------------------- plm_available <- requireNamespace("plm", quietly = TRUE) if (!plm_available) cat("## Building the remainder of the vignette requires the plm package. Please install it. {-}") ## ----message = FALSE, eval = plm_available-------------------------------------------------------- library(plm) plm_unweighted <- plm(mrate ~ legal + beertaxa, data = MV_deaths, effect = "twoways", index = c("state","year")) coef_test(plm_unweighted, vcov = "CR1", cluster = "individual", test = "naive-t") coef_test(plm_unweighted, vcov = "CR2", cluster = "individual", test = "Satterthwaite") ## ------------------------------------------------------------------------------------------------- lm_weighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), weights = pop, data = MV_deaths) coef_test(lm_weighted, vcov = "CR1", cluster = MV_deaths$state, test = "naive-t")[1:2,] coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, test = "Satterthwaite")[1:2,] ## ------------------------------------------------------------------------------------------------- coef_test(lm_weighted, vcov = "CR2", cluster = MV_deaths$state, target = 1 / MV_deaths$pop, test = "Satterthwaite")[1:2,] ## ----eval = plm_available------------------------------------------------------------------------- plm_random <- plm(mrate ~ 0 + legal + beertaxa + year, data = MV_deaths, effect = "individual", index = c("state","year"), model = "random") coef_test(plm_random, vcov = "CR1", test = "naive-t")[1:2,] coef_test(plm_random, vcov = "CR2", test = "Satterthwaite")[1:2,] ## ----eval = plm_available------------------------------------------------------------------------- MV_deaths <- within(MV_deaths, { legal_cent <- legal - tapply(legal, state, mean)[factor(state)] beer_cent <- beertaxa - tapply(beertaxa, state, mean)[factor(state)] }) plm_Hausman <- plm(mrate ~ 0 + legal + beertaxa + legal_cent + beer_cent + factor(year), data = MV_deaths, effect = "individual", index = c("state","year"), model = "random") coef_test(plm_Hausman, vcov = "CR2", test = "Satterthwaite")[1:4,] ## ----eval = plm_available------------------------------------------------------------------------- Wald_test(plm_Hausman, constraints = constrain_zero(c("legal_cent","beer_cent")), vcov = "CR1", test = "chi-sq") ## ----eval = plm_available------------------------------------------------------------------------- Wald_test(plm_Hausman, constraints = constrain_zero(c("legal_cent","beer_cent")), vcov = "CR2") clubSandwich/inst/doc/meta-analysis-with-CRVE.R0000644000176200001440000000532614635065005021014 0ustar liggesusers## ----echo = FALSE, results = "asis", message = FALSE, warning = FALSE--------- robu_available <- requireNamespace("robumeta", quietly = TRUE) meta_available <- requireNamespace("metafor", quietly = TRUE) knitr::opts_chunk$set(eval = robu_available & meta_available) if (!robu_available) cat("## Building this vignette requires the robumeta package. Please install it. {-} \n") if (!meta_available) cat("## Building this vignette requires the metafor package. Please install it. {-} \n") ## ----include=FALSE-------------------------------------------------------------------------------- options(width = 100) ## ----message = FALSE------------------------------------------------------------------------------ library(clubSandwich) library(robumeta) data(dropoutPrevention) # clean formatting names(dropoutPrevention)[7:8] <- c("eval","implement") levels(dropoutPrevention$eval) <- c("independent","indirect","planning","delivery") levels(dropoutPrevention$implement) <- c("low","medium","high") levels(dropoutPrevention$program_site) <- c("community","mixed","classroom","school") levels(dropoutPrevention$study_design) <- c("matched","unmatched","RCT") levels(dropoutPrevention$adjusted) <- c("no","yes") m3_robu <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs, data = dropoutPrevention, studynum = studyID, var.eff.size = varLOR, modelweights = "HIER") print(m3_robu) ## ------------------------------------------------------------------------------------------------- Wald_test(m3_robu, constraints = constrain_zero(10:12), vcov = "CR2") ## ------------------------------------------------------------------------------------------------- table(dropoutPrevention$eval) ## ----message = FALSE------------------------------------------------------------------------------ library(metafor) m3_metafor <- rma.mv(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs, V = varLOR, random = list(~ 1 | studyID, ~ 1 | studySample), data = dropoutPrevention) summary(m3_metafor) ## ------------------------------------------------------------------------------------------------- coef_test(m3_metafor, vcov = "CR2") ## ------------------------------------------------------------------------------------------------- Wald_test(m3_metafor, constraints = constrain_zero(10:12), vcov = "CR2") clubSandwich/inst/doc/meta-analysis-with-CRVE.Rmd0000644000176200001440000001556514630154052021337 0ustar liggesusers--- title: "Meta-analysis with cluster-robust variance estimation" author: "James E. Pustejovsky" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Meta-analysis with cluster-robust variance estimation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, echo = FALSE, results = "asis", message = FALSE, warning = FALSE} robu_available <- requireNamespace("robumeta", quietly = TRUE) meta_available <- requireNamespace("metafor", quietly = TRUE) knitr::opts_chunk$set(eval = robu_available & meta_available) if (!robu_available) cat("## Building this vignette requires the robumeta package. Please install it. {-} \n") if (!meta_available) cat("## Building this vignette requires the metafor package. Please install it. {-} \n") ``` This vignette demonstrates how to use the `clubSandwich` package to conduct a meta-analysis of dependent effect sizes with robust variance estimation. Tests of meta-regression coefficients and F-tests of multiple-coefficient hypotheses are calculated using small-sample corrections proposed by Tipton (2015) and Tipton and Pustejovsky (2015). The example uses a dataset of effect sizes from a Campbell Collaboration systematic review of dropout prevention programs, conducted by Sandra Jo Wilson and colleagues (2011). The original analysis included a meta-regression with covariates that capture methodological, participant, and program characteristics. The regression specification used here is similar to Model III from Wilson et al. (2011), but treats the `evaluator_independence` and `implementation_quality` variables as categorical rather than interval-level. Also, the original analysis clustered at the level of the sample (some studies reported results from multiple samples), whereas here we cluster at the study level. The meta-regression can be fit in several different ways. We first demonstrate using the `robumeta` package (Fisher & Tipton, 2015) and then using the `metafor` package (Viechtbauer, 2010). ## robumeta model ```{r, include=FALSE} options(width = 100) ``` ```{r, message = FALSE} library(clubSandwich) library(robumeta) data(dropoutPrevention) # clean formatting names(dropoutPrevention)[7:8] <- c("eval","implement") levels(dropoutPrevention$eval) <- c("independent","indirect","planning","delivery") levels(dropoutPrevention$implement) <- c("low","medium","high") levels(dropoutPrevention$program_site) <- c("community","mixed","classroom","school") levels(dropoutPrevention$study_design) <- c("matched","unmatched","RCT") levels(dropoutPrevention$adjusted) <- c("no","yes") m3_robu <- robu(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs, data = dropoutPrevention, studynum = studyID, var.eff.size = varLOR, modelweights = "HIER") print(m3_robu) ``` Note that `robumeta` produces small-sample corrected standard errors and t-tests, and so there is no need to repeat those calculations with `clubSandwich`. The `eval` variable has four levels, and it might be of interest to test whether the average program effects differ by the degree of evaluator independence. The null hypothesis in this case is that the 10th, 11th, and 12th regression coefficients are all equal to zero. A small-sample adjusted F-test for this hypothesis can be obtained as follows. The `vcov = "CR2"` option means that the standard errors will be corrected using the bias-reduced linearization estimator described in Tipton and Pustejovsky (2015). ```{r} Wald_test(m3_robu, constraints = constrain_zero(10:12), vcov = "CR2") ``` By default, the `Wald_test` function provides an F-type test with degrees of freedom estimated using the approximate Hotelling's $T^2_Z$ method. The test has less than 17 degrees of freedom, even though there are 152 independent studies in the data, and has a p-value that is not quite significant at conventional levels. The low degrees of freedom are a consequence of the fact that one of the levels of `evaluator independence` has only a few effect sizes in it: ```{r} table(dropoutPrevention$eval) ``` ## metafor model `clubSandwich` also works with models fit using the `metafor` package. Here we re-fit the same regression specification, but use REML to estimate the variance components (`robumeta` uses a method-of-moments estimator), as well as a somewhat different weighting scheme than that used in `robumeta`. ```{r, message = FALSE} library(metafor) m3_metafor <- rma.mv(LOR1 ~ study_design + attrition + group_equivalence + adjusted + outcome + eval + male_pct + white_pct + average_age + implement + program_site + duration + service_hrs, V = varLOR, random = list(~ 1 | studyID, ~ 1 | studySample), data = dropoutPrevention) summary(m3_metafor) ``` `metafor` produces model-based standard errors, t-tests, and confidence intervals. The `coef_test` function from `clubSandwich` will calculate robust standard errors and robust t-tests for each of the coefficients: ```{r} coef_test(m3_metafor, vcov = "CR2") ``` Note that `coef_test` assumed that it should cluster based on `studyID`, which is the outer-most random effect in the metafor model. This can be specified explicitly by including the option `cluster = dropoutPrevention$studyID` in the call. The F-test for degree of evaluator independence uses the same syntax as before: ```{r} Wald_test(m3_metafor, constraints = constrain_zero(10:12), vcov = "CR2") ``` Despite some differences in weighting schemes, the p-value is very close to the result obtained using `robumeta`. ## References Fisher, Z., & Tipton, E. (2015). robumeta: An R-package for robust variance estimation in meta-analysis. [arXiv:1503.02220](https://arxiv.org/abs/1503.02220) Tipton, E. (2015). Small sample adjustments for robust variance estimation with meta-regression. _Psychological Methods, 20_(3), 375-393. https://doi.org/10.1037/met0000011 Tipton, E., & Pustejovsky, J. E. (2015). Small-sample adjustments for tests of moderators and model fit using robust variance estimation in meta-regression. _Journal of Educational and Behavioral Statistics, 40_(6), 604-634. https://doi.org/10.3102/1076998615606099 Viechtbauer, W. (2010). Conducting meta-analyses in R with the metafor package. _Journal of Statistical Software, 36_(3), 1-48. URL: https://doi.org/10.18637/jss.v036.i03 Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: Effects on school completion and dropout Among school-aged children and youth: A systematic review. _Campbell Systematic Reviews, 7_(1), 1-61. https://doi.org/10.4073/csr.2011.8 clubSandwich/inst/doc/Wald-tests-in-clubSandwich.R0000644000176200001440000001370014635065002021566 0ustar liggesusers## ----echo = FALSE, results = "asis", message = FALSE, warning = FALSE--------- library(clubSandwich) AER_available <- requireNamespace("AER", quietly = TRUE) knitr::opts_chunk$set(eval = AER_available) if (!AER_available) cat("# Building this vignette requires the AER package. Please install it. {-}") ## ----message = FALSE, warning = FALSE----------------------------------------- library(clubSandwich) data(STAR, package = "AER") # clean up a few variables levels(STAR$stark)[3] <- "aide" levels(STAR$schoolk)[1] <- "urban" STAR <- subset(STAR, !is.na(schoolidk), select = c(schoolidk, schoolk, stark, gender, ethnicity, math1, lunchk)) head(STAR) ## ----------------------------------------------------------------------------- args(Wald_test) ## ----type-treat--------------------------------------------------------------- lm_trt <- lm(math1 ~ stark, data = STAR) V_trt <- vcovCR(lm_trt, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_trt, vcov = V_trt) ## ----------------------------------------------------------------------------- C_trt <- matrix(c(0,0,1,0,0,1), 2, 3) C_trt Wald_test(lm_trt, constraints = C_trt, vcov = V_trt) ## ----------------------------------------------------------------------------- args(constrain_zero) ## ----------------------------------------------------------------------------- constrain_zero(2:3, coefs = coef(lm_trt)) ## ----------------------------------------------------------------------------- constrain_zero(c("starksmall","starkaide"), coefs = coef(lm_trt)) ## ----------------------------------------------------------------------------- constrain_zero("^stark", coefs = coef(lm_trt), reg_ex = TRUE) ## ----------------------------------------------------------------------------- C_trt <- constrain_zero(2:3, coefs = coef(lm_trt)) Wald_test(lm_trt, constraints = C_trt, vcov = V_trt) ## ----------------------------------------------------------------------------- Wald_test(lm_trt, constraints = constrain_zero(2:3), vcov = V_trt) ## ----type-sep----------------------------------------------------------------- lm_sep <- lm(math1 ~ 0 + stark, data = STAR) V_sep <- vcovCR(lm_sep, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_sep, vcov = V_sep) ## ----------------------------------------------------------------------------- args(constrain_equal) ## ----------------------------------------------------------------------------- constrain_equal(1:3, coefs = coef(lm_sep)) ## ----------------------------------------------------------------------------- constrain_equal(c("starkregular","starksmall","starkaide"), coefs = coef(lm_sep)) ## ----------------------------------------------------------------------------- constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE) ## ----------------------------------------------------------------------------- C_sep <- constrain_equal("^stark", coefs = coef(lm_sep), reg_ex = TRUE) Wald_test(lm_sep, constraints = C_sep, vcov = V_sep) ## ----------------------------------------------------------------------------- Wald_test(lm_sep, constraints = constrain_equal(1:3), vcov = V_sep) ## ----------------------------------------------------------------------------- lm_urbanicity <- lm(math1 ~ schoolk * stark + gender + ethnicity + lunchk, data = STAR) V_urbanicity <- vcovCR(lm_urbanicity, cluster = STAR$schoolidk, type = "CR2") coef_test(lm_urbanicity, vcov = V_urbanicity) ## ----------------------------------------------------------------------------- Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:stark", reg_ex = TRUE), vcov = V_urbanicity) ## ----------------------------------------------------------------------------- Wald_test(lm_urbanicity, constraints = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE), vcov = V_urbanicity) ## ----------------------------------------------------------------------------- C_list <- list( `Any interaction` = constrain_zero("schoolk.+:stark", coef(lm_urbanicity), reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", coef(lm_urbanicity), reg_ex = TRUE) ) Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity) ## ----------------------------------------------------------------------------- Wald_test(lm_urbanicity, constraints = C_list, vcov = V_urbanicity, tidy = TRUE) ## ----------------------------------------------------------------------------- Wald_test( lm_urbanicity, constraints = list( `Any interaction` = constrain_zero("schoolk.+:stark", reg_ex = TRUE), `Small vs regular` = constrain_zero("schoolk.+:starksmall", reg_ex = TRUE) ), vcov = V_urbanicity, tidy = TRUE ) ## ----------------------------------------------------------------------------- coef_test(lm_sep, vcov = V_sep) ## ----------------------------------------------------------------------------- C_pairs <- constrain_pairwise(1:3, coefs = coef(lm_sep)) C_pairs ## ----------------------------------------------------------------------------- Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE) ## ----------------------------------------------------------------------------- t_stats <- coef_test(lm_trt, vcov = V_trt)$tstat[2:3] F_stats <- Wald_test(lm_sep, constraints = C_pairs, vcov = V_sep, tidy = TRUE)$Fstat[1:2] all.equal(t_stats^2, F_stats) ## ----------------------------------------------------------------------------- coef_test(lm_urbanicity, vcov = V_urbanicity) ## ----------------------------------------------------------------------------- Wald_test(lm_urbanicity, constraints = constrain_pairwise(":starksmall", reg_ex = TRUE, with_zero = TRUE), vcov = V_urbanicity, tidy = TRUE) clubSandwich/inst/doc/panel-data-CRVE.html0000644000176200001440000011244114635065007020044 0ustar liggesusers Cluster-robust standard errors and hypothesis tests in panel data models

Cluster-robust standard errors and hypothesis tests in panel data models

James E. Pustejovsky

2024-06-20

The importance of using cluster-robust variance estimators (i.e., “clustered standard errorsâ€) in panel models is now widely recognized. Less widely recognized is the fact that standard methods for constructing hypothesis tests and confidence intervals based on CRVE can perform quite poorly in when based on a limited number of independent clusters. Furthermore, it can be difficult to determine what counts as a large-enough sample to trust standard CRVE methods, because the finite-sample behavior of the variance estimators and test statistics depends on the configuration of the covariates, not just the total number of clusters.

One solution to this problem is to use bias-reduced linearization (BRL), which was proposed by Bell and McCaffrey (2002) and has recently begun to receive attention in the econometrics literature (e.g., Cameron & Miller, 2015; Imbens & Kolesar, 2015). The idea of BRL is to correct the bias of standard CRVE based on a working model, and then to use a degrees-of-freedom correction for Wald tests based on the bias-reduced CRVE. That may seem silly (after all, the whole point of CRVE is to avoid making distributional assumptions about the errors in your model), but it turns out that the correction can help quite a bit, even when the working model is wrong. The degrees-of-freedom correction is based on a standard Satterthwaite-type approximation, and also relies on the working model.

A problem with Bell and McCaffrey’s original formulation of BRL is that it does not work in some very common models for panel data, such as state-by-year panels that include fixed effects for each state and each year (Angrist and Pischke, 2009, point out this issue in their chapter on “non-standard standard error issuesâ€; see also Young, 2016). However, Pustejovsky and Tipton (2016) proposed a generalization of BRL that works even in models with arbitrary sets of fixed effects, and this generalization is implemented in clubSandwich as CRVE type CR2. The package also implements small-sample corrections for multiple-constraint hypothesis tests based on an approximation proposed by Pustejovsky and Tipton (2016). For one-parameter constraints, the test reduces to a t-test with Satterthwaite degrees of freedom, and so it is a natural extension of BRL.

The following example demonstrates how to use clubSandwich to do cluster-robust inference for a state-by-year panel model with fixed effects in both dimensions, clustering by states.

Unweighted OLS

The following code does some simple data-munging and the estimates the model by OLS:

library(clubSandwich)
data(MortalityRates)

# subset for deaths in motor vehicle accidents, 1970-1983
MV_deaths <- subset(MortalityRates, cause=="Motor Vehicle" & 
                      year <= 1983 & !is.na(beertaxa))

# fit by OLS
lm_unweighted <- lm(mrate ~ 0 + legal + beertaxa + 
                      factor(state) + factor(year), data = MV_deaths)

The coef_test function from clubSandwich can then be used to test the hypothesis that changing the minimum legal drinking age has no effect on motor vehicle deaths in this cohort (i.e., \(H_0: \delta = 0\)). The usual way to test this is to cluster the standard errors by state, calculate the robust Wald statistic, and compare that to a standard normal reference distribution. The code and results are as follows:

coef_test(lm_unweighted, vcov = "CR1", 
          cluster = MV_deaths$state, test = "naive-t")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (naive-t) p-val (naive-t) Sig.
##     legal     7.59 2.44  3.108             49         0.00313   **
##  beertaxa     3.82 5.14  0.743             49         0.46128

A better approach would be to use the generalized, bias-reduced linearization CRVE, together with Satterthwaite degrees of freedom. In the clubSandwich package, the BRL adjustment is called “CR2†because it is directly analogous to the HC2 correction used in heteroskedasticity-robust variance estimation. When applied to an OLS model estimated by lm, the default working model is an identity matrix, which amounts to the “working†assumption that the errors are all uncorrelated and homoskedastic. Here’s how to apply this approach in the example:

coef_test(lm_unweighted, vcov = "CR2", 
          cluster = MV_deaths$state, test = "Satterthwaite")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##     legal     7.59 2.51  3.019       24.58      0.00583   **
##  beertaxa     3.82 5.27  0.725        5.77      0.49663

The Satterthwaite degrees of freedom are different for each coefficient in the model, and so the coef_test function reports them right alongside the standard error. For the effect of legal drinking age, the degrees of freedom are about half of what might be expected, given that there are 51 clusters. The p-value for the CR2+Satterthwaite test is about twice as large as the p-value based on the standard Wald test, although the coefficient is still statistically significant at conventional levels. Note, however, that the degrees of freedom on the beer taxation rate are considerably smaller because there are only a few states with substantial variability in taxation rates over time.

Unweighted “within†estimation

The plm package in R provides another way to estimate the same model. It is convenient because it absorbs the state and year fixed effects before estimating the effect of legal. The clubSandwich package works with fitted plm models too:

library(plm)
plm_unweighted <- plm(mrate ~ legal + beertaxa, data = MV_deaths, 
                      effect = "twoways", index = c("state","year"))
coef_test(plm_unweighted, vcov = "CR1", cluster = "individual", test = "naive-t")
##     Coef. Estimate   SE t-stat d.f. (naive-t) p-val (naive-t) Sig.
##     legal     7.59 2.44  3.108             49         0.00313   **
##  beertaxa     3.82 5.14  0.743             49         0.46128
coef_test(plm_unweighted, vcov = "CR2", cluster = "individual", test = "Satterthwaite")
##     Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##     legal     7.59 2.51  3.019       24.58      0.00583   **
##  beertaxa     3.82 5.27  0.725        5.77      0.49663

Population-weighted estimation

The difference between the standard method and the new method are not terribly exciting in the above example. However, things change quite a bit if the model is estimated using population weights. We go back to fitting in lm with dummies for all the fixed effects because plm does not handle weighted least squares.

lm_weighted <- lm(mrate ~ 0 + legal + beertaxa + factor(state) + factor(year), 
                  weights = pop, data = MV_deaths)
coef_test(lm_weighted, vcov = "CR1", 
          cluster = MV_deaths$state, test = "naive-t")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (naive-t) p-val (naive-t) Sig.
##     legal     7.78 2.01   3.87             49          <0.001  ***
##  beertaxa    11.16 4.20   2.66             49          0.0106    *
coef_test(lm_weighted, vcov = "CR2", 
          cluster = MV_deaths$state, test = "Satterthwaite")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##     legal     7.78 2.13   3.64        8.52      0.00588   **
##  beertaxa    11.16 4.37   2.55        6.85      0.03854    *

Using population weights slightly reduces the point estimate of the effect, while also slightly increasing its precision. If you were following the standard approach, you would probably be happy with the weighted estimates and wouldn’t think about it any further. However, using the CR2 variance estimator and Satterthwaite correction produces a p-value that is an order of magnitude larger (though still significant at the conventional 5% level). The degrees of freedom are just 8.5—drastically smaller than would be expected based on the number of clusters.

Even with weights, the coef_test function uses an “independent, homoskedastic†working model as a default for lm objects. In the present example, the outcome is a standardized rate and so a better assumption might be that the error variances are inversely proportional to population size. The following code uses this alternate working model:

coef_test(lm_weighted, vcov = "CR2", 
          cluster = MV_deaths$state, target = 1 / MV_deaths$pop, 
          test = "Satterthwaite")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##     legal     7.78 2.03   3.83       12.64      0.00221   **
##  beertaxa    11.16 4.17   2.68        5.06      0.04333    *

The new working model leads to slightly smaller standard errors and a couple of additional degrees of freedom, though they remain in small-sample territory.

Random effects estimation

If the unobserved effects \(\alpha_1,...,\alpha_{51}\) are uncorrelated with the regressors, then a more efficient way to estimate \(\gamma,\delta\) is by weighted least squares, with weights based on a random effects model. We still treat the year effects as fixed.

plm_random <- plm(mrate ~ 0 + legal + beertaxa + year, data = MV_deaths, 
                  effect = "individual", index = c("state","year"),
                  model = "random")
coef_test(plm_random, vcov = "CR1", test = "naive-t")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (naive-t) p-val (naive-t) Sig.
##     legal     7.31 2.39  3.054             49         0.00364   **
##  beertaxa     3.37 5.11  0.661             49         0.51202
coef_test(plm_random, vcov = "CR2", test = "Satterthwaite")[1:2,]
##     Coef. Estimate   SE t-stat d.f. (Satt) p-val (Satt) Sig.
##     legal     7.31 2.46  2.966       25.18      0.00652   **
##  beertaxa     3.37 5.22  0.647        5.78      0.54258

With random effects estimation, the effect of legal drinking age is smaller by about 1 death per 100,000. As a procedural aside, note that coef_test infers that state is the clustering variable because the call to plm includes only one type of effects (random state effects).

Robust Hausman test

CRVE is also used in specification tests, as in the artificial Hausman-type test for endogeneity of unobserved effects (Arellano, 1993). As noted above, random effects estimation is more efficient than fixed effects estimation, but requires the assumption that the unobserved effects are uncorrelated with the regressors. However, if the unobserved effects covary with \(\mathbf{b}_i, \mathbf{d}_i\), then the random-effects estimator will be biased.

We can test for whether endogeneity is a problem by including group-centered covariates as additional regressors. Let \(\tilde{d}_{it} = d_{it} - \frac{1}{T}\sum_t d_{it}\), with \(\tilde{b}_{it}\) defined analogously. Now estimate the regression

\[y_{it} = \beta_t + \gamma_1 b_{it} + \gamma_2 \tilde{b}_{it} + \delta_1 d_{it} + \delta_2 \tilde{d}_{it} + \epsilon_{it},\]

which does not include state fixed effects. The parameters \(\gamma_2,\delta_2\) represent the differences between the within-groups and between-groups estimands of \(\gamma_1, \delta_1\). If these are both zero, then the random effects estimator is unbiased. Thus, the joint test for \(H_0: \gamma_2 = \delta_2 = 0\) amounts to a test for exogeneity of the unobserved effects.

For efficiency, we estimate this specification using weighted least squares (although OLS would be valid too):

MV_deaths <- within(MV_deaths, {
  legal_cent <- legal - tapply(legal, state, mean)[factor(state)]
  beer_cent <- beertaxa - tapply(beertaxa, state, mean)[factor(state)]
})

plm_Hausman <- plm(mrate ~ 0 + legal + beertaxa + legal_cent + beer_cent + factor(year), 
                   data = MV_deaths,
                   effect = "individual", index = c("state","year"),
                   model = "random")
coef_test(plm_Hausman, vcov = "CR2", test = "Satterthwaite")[1:4,]
##       Coef. Estimate   SE  t-stat d.f. (Satt) p-val (Satt) Sig.
##       legal   -9.180 7.62 -1.2042       24.94       0.2398     
##    beertaxa    3.395 9.40  0.3613        6.44       0.7295     
##  legal_cent   16.768 8.53  1.9665       25.44       0.0602    .
##   beer_cent    0.424 9.25  0.0458        6.42       0.9648

To conduct a joint test on the centered covariates, we can use the Wald_test function. The usual way to test this hypothesis would be to use the CR1 variance estimator to calculate the robust Wald statistic, then use a \(\chi^2_2\) reference distribution (or equivalently, compare a re-scaled Wald statistic to an \(F(2,\infty)\) distribution). The Wald_test function reports the latter version:

Wald_test(plm_Hausman, 
          constraints = constrain_zero(c("legal_cent","beer_cent")), 
          vcov = "CR1", test = "chi-sq")
##    test Fstat df_num df_denom  p_val sig
##  chi-sq  2.93      2      Inf 0.0534   .

The test is just shy of significance at the 5% level. If we instead use the CR2 variance estimator and our newly proposed approximate F-test (which is the default in Wald_test), then we get:

Wald_test(plm_Hausman, 
          constraints = constrain_zero(c("legal_cent","beer_cent")), 
          vcov = "CR2")
##  test Fstat df_num df_denom p_val sig
##   HTZ  2.56      2     11.7  0.12

The low degrees of freedom of the test indicate that we’re definitely in small-sample territory and should not trust the asymptotic \(\chi^2\) approximation.

References

Angrist, J. D., & Pischke, J. (2009). Mostly harmless econometrics: An empiricist’s companion. Princeton, NJ: Princeton University Press.

Angrist, J. D., and Pischke, J. S. (2014). Mastering’metrics: the path from cause to effect. Princeton, NJ: Princeton University Press.

Arellano, M. (1993). On the testing of correlated effects with panel data. Journal of Econometrics, 59(1-2), 87-97. doi: 10.1016/0304-4076(93)90040-C

Bell, R. M., & McCaffrey, D. F. (2002). Bias reduction in standard errors for linear regression with multi-stage samples. Survey Methodology, 28(2), 169-181.

Cameron, A. C., & Miller, D. L. (2015). A practitioner’s guide to cluster-robust inference. URL: https://cameron.econ.ucdavis.edu/research/Cameron_Miller_JHR_2015_February.pdf

Carpenter, C., & Dobkin, C. (2011). The minimum legal drinking age and public health. Journal of Economic Perspectives, 25(2), 133-156. doi: 10.1257/jep.25.2.133

Imbens, G. W., & Kolesar, M. (2015). Robust standard errors in small samples: Some practical advice. URL: https://doi.org/10.1162/REST_a_00552

Pustejovsky, J. E. & Tipton, E. (2016). Small sample methods for cluster-robust variance estimation and hypothesis testing in fixed effects models. arXiv: 1601.01981 [stat.ME]

Young, A. (2016). Improved, nearly exact, statistical inference with robust and clustered covariance matrices using effective degrees of freedom corrections.

clubSandwich/build/0000755000176200001440000000000014635065010013757 5ustar liggesusersclubSandwich/build/vignette.rds0000644000176200001440000000056214635065010016321 0ustar liggesusers‹…’ÝJÃ0dzµN7”y#Í dà…O°9dŠz›µg4&%É,»óÅužtéX§Î‹žääü“ßùè[Ò&q‘v„Û¨¦ƒß‰wHLº¸^¾r™2ÖY&KäböÄUZŠ$Nó4¨.rpœqÅåÒ ËJá26š¾ÜnIúW YÊQ¸ 5YמE+Õsš/¤…–heáB9ªRÒlYh—.Þìù çï£÷õ !Ì…d*clubSandwich/build/partial.rdb0000644000176200001440000000007514635064767016130 0ustar liggesusers‹‹àb```b`aff`b1…À€… H02°0piÖ¼ÄÜÔb C"Éð4¾è÷7clubSandwich/man/0000755000176200001440000000000014634640072013441 5ustar liggesusersclubSandwich/man/SATcoaching.Rd0000644000176200001440000000247614630154051016055 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-documentation.R \docType{data} \name{SATcoaching} \alias{SATcoaching} \title{Randomized experiments on SAT coaching} \format{ A data frame with 67 rows and 11 variables: \describe{ \item{study}{Study identifier} \item{year}{Year of publication} \item{test}{Character string indicating whether effect size corresponds to outcome on verbal (SATV) or math (SATM) test} \item{d}{Effect size estimate (Standardized mean difference)} \item{V}{Variance of effect size estimate} \item{nT}{Sample size in treatment condition} \item{nC}{Sample size in control condition} \item{study_type}{Character string indicating whether study design used a matched, non-equivalent, or randomized control group} \item{hrs}{Hours of coaching} \item{ETS}{Indicator variable for Educational Testing Service} \item{homework}{Indicator variable for homework} } } \usage{ SATcoaching } \description{ Effect sizes from studies on the effects of SAT coaching, reported in Kalaian and Raudenbush (1996) } \references{ Kalaian, H. A. & Raudenbush, S. W. (1996). A multivariate mixed linear model for meta-analysis. \emph{Psychological Methods, 1}(3), 227-235. \doi{10.1037/1082-989X.1.3.227} } \keyword{datasets} clubSandwich/man/coef_test.Rd0000644000176200001440000000504414630154051015677 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coef_test.R \name{coef_test} \alias{coef_test} \title{Test all or selected regression coefficients in a fitted model} \usage{ coef_test( obj, vcov, test = "Satterthwaite", coefs = "All", p_values = TRUE, ... ) } \arguments{ \item{obj}{Fitted model for which to calculate t-tests.} \item{vcov}{Variance covariance matrix estimated using \code{vcovCR} or a character string specifying which small-sample adjustment should be used to calculate the variance-covariance.} \item{test}{Character vector specifying which small-sample corrections to calculate. \code{"z"} returns a z test (i.e., using a standard normal reference distribution). \code{"naive-t"} returns a t test with \code{m - 1} degrees of freedom, where \code{m} is the number of unique clusters. \code{"naive-tp"} returns a t test with \code{m - p} degrees of freedom, where \code{p} is the number of regression coefficients in \code{obj}. \code{"Satterthwaite"} returns a Satterthwaite correction. \code{"saddlepoint"} returns a saddlepoint correction. Default is \code{"Satterthwaite"}.} \item{coefs}{Character, integer, or logical vector specifying which coefficients should be tested. The default value \code{"All"} will test all estimated coefficients.} \item{p_values}{Logical indicating whether to report p-values. The default value is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link{vcovCR}}, which are only needed if \code{vcov} is a character string.} } \value{ A data frame containing estimated regression coefficients, standard errors, and test results. For the Satterthwaite approximation, degrees of freedom and a p-value are reported. For the saddlepoint approximation, the saddlepoint and a p-value are reported. } \description{ \code{coef_test} reports t-tests for each coefficient estimate in a fitted linear regression model, using a sandwich estimator for the standard errors and a small sample correction for the p-value. The small-sample correction is based on a Satterthwaite approximation or a saddlepoint approximation. } \examples{ data("ChickWeight", package = "datasets") lm_fit <- lm(weight ~ Diet * Time, data = ChickWeight) diet_index <- grepl("Diet.:Time", names(coef(lm_fit))) coef_test(lm_fit, vcov = "CR2", cluster = ChickWeight$Chick, coefs = diet_index) V_CR2 <- vcovCR(lm_fit, cluster = ChickWeight$Chick, type = "CR2") coef_test(lm_fit, vcov = V_CR2, coefs = diet_index) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.lm.Rd0000644000176200001440000000615514630154051015541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lm.R \name{vcovCR.lm} \alias{vcovCR.lm} \title{Cluster-robust variance-covariance matrix for an lm object.} \usage{ \method{vcovCR}{lm}( obj, cluster, type, target = NULL, inverse_var = NULL, form = "sandwich", ... ) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Expression or vector indicating which observations belong to the same cluster. Required for \code{lm} objects.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If a vector, the target matrix is assumed to be diagonal. If not specified, the target is taken to be an identity matrix.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from an \code{\link{lm}} object. } \examples{ data("ChickWeight", package = "datasets") lm_fit <- lm(weight ~ Time + Diet:Time, data = ChickWeight) vcovCR(lm_fit, cluster = ChickWeight$Chick, type = "CR2") if (requireNamespace("plm", quietly = TRUE)) withAutoprint({ data("Produc", package = "plm") lm_individual <- lm(log(gsp) ~ 0 + state + log(pcap) + log(pc) + log(emp) + unemp, data = Produc) individual_index <- !grepl("state", names(coef(lm_individual))) vcovCR(lm_individual, cluster = Produc$state, type = "CR2")[individual_index,individual_index] # compare to plm() plm_FE <- plm::plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year"), effect = "individual", model = "within") vcovCR(plm_FE, type="CR2") }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.robu.Rd0000644000176200001440000000577514630154051016107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/robu.R \name{vcovCR.robu} \alias{vcovCR.robu} \title{Cluster-robust variance-covariance matrix for a robu object.} \usage{ \method{vcovCR}{robu}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional expression or vector indicating which observations belong to the same cluster. If not specified, will be set to the \code{studynum} used in fitting the \code{\link[robumeta]{robu}} object.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be the inverse of the estimated weights used in fitting the \code{\link[robumeta]{robu}} object.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from a \code{\link[robumeta]{robu}} object. } \examples{ if (requireNamespace("robumeta", quietly = TRUE)) withAutoprint({ library(robumeta) data(hierdat) robu_fit <- robu(effectsize ~ binge + followup + sreport + age, data = hierdat, studynum = studyid, var.eff.size = var, modelweights = "HIER") robu_fit robu_CR2 <- vcovCR(robu_fit, type = "CR2") robu_CR2 coef_test(robu_fit, vcov = robu_CR2, test = c("Satterthwaite", "saddlepoint")) Wald_test(robu_fit, constraints = constrain_zero(c(2,4)), vcov = robu_CR2) Wald_test(robu_fit, constraints = constrain_zero(2:5), vcov = robu_CR2) }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.geeglm.Rd0000644000176200001440000000544714630154051016374 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/geeglm.R \name{vcovCR.geeglm} \alias{vcovCR.geeglm} \title{Cluster-robust variance-covariance matrix for a geeglm object.} \usage{ \method{vcovCR}{geeglm}( obj, cluster, type, target = NULL, inverse_var = NULL, form = "sandwich", ... ) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Expression or vector indicating which observations belong to the same cluster. Required for \code{geeglm} objects.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If a vector, the target matrix is assumed to be diagonal. If not specified, the target is taken to be the estimated variance function.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from an \code{\link[geepack]{geeglm}} object. } \examples{ if (requireNamespace("geepack", quietly = TRUE)) { library(geepack) data(dietox, package = "geepack") dietox$Cu <- as.factor(dietox$Cu) mf <- formula(Weight ~ Cu * (Time + I(Time^2) + I(Time^3))) gee1 <- geeglm(mf, data=dietox, id=Pig, family=poisson("identity"), corstr="ar1") V_CR <- vcovCR(gee1, cluster = dietox$Pig, type = "CR2") coef_test(gee1, vcov = V_CR, test = "Satterthwaite") } } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.lme.Rd0000644000176200001440000000606714630154051015710 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lme.R \name{vcovCR.lme} \alias{vcovCR.lme} \title{Cluster-robust variance-covariance matrix for an lme object.} \usage{ \method{vcovCR}{lme}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional expression or vector indicating which observations belong to the same cluster. If not specified, will be set to \code{getGroups(obj)}.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be the estimated variance-covariance structure of the \code{lme} object.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from a \code{\link[nlme]{lme}} object. } \examples{ if (requireNamespace("nlme", quietly = TRUE)) { library(nlme) rat_weight <- lme(weight ~ Time * Diet, data=BodyWeight, ~ Time | Rat) vcovCR(rat_weight, type = "CR2") } pkgs_available <- requireNamespace("nlme", quietly = TRUE) & requireNamespace("mlmRev", quietly = TRUE) if (pkgs_available) { data(egsingle, package = "mlmRev") subset_ids <- levels(egsingle$schoolid)[1:10] egsingle_subset <- subset(egsingle, schoolid \%in\% subset_ids) math_model <- lme(math ~ year * size + female + black + hispanic, random = list(~ year | schoolid, ~ 1 | childid), data = egsingle_subset) vcovCR(math_model, type = "CR2") } } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/MortalityRates.Rd0000644000176200001440000000303214635054714016714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-documentation.R \docType{data} \name{MortalityRates} \alias{MortalityRates} \title{State-level annual mortality rates by cause among 18-20 year-olds} \format{ A data frame with 5508 rows and 12 variables: \describe{ \item{year}{Year of observation} \item{state}{identifier for state} \item{count}{Number of deaths} \item{pop}{Population size} \item{legal}{Proportion of 18-20 year-old population that is legally allowed to drink} \item{beertaxa}{Beer taxation rate} \item{beerpercap}{Beer consumption per capita} \item{winepercap}{Wine consumption per capita} \item{spiritpercap}{Spirits consumption per capita} \item{totpercap}{Total alcohol consumption per capita} \item{mrate}{Mortality rate per 10,000} \item{cause}{Cause of death} } } \source{ \href{https://masteringmetrics.com/wp-content/uploads/2015/01/deaths.dta}{Mastering 'Metrics data archive} } \usage{ MortalityRates } \description{ A dataset containing state-level annual mortality rates for select causes of death, as well as data related to the minimum legal drinking age and alcohol consumption. } \references{ Angrist, J. D., and Pischke, J. S. (2014). _Mastering'metrics: the path from cause to effect_. Princeton University Press, 2014. Carpenter, C., & Dobkin, C. (2011). The minimum legal drinking age and public health. _Journal of Economic Perspectives, 25_(2), 133-156. \doi{10.1257/jep.25.2.133} } \keyword{datasets} clubSandwich/man/pattern_covariance_matrix.Rd0000644000176200001440000001326714630154051021165 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rma-mv.R \name{pattern_covariance_matrix} \alias{pattern_covariance_matrix} \title{Impute a patterned block-diagonal covariance matrix} \usage{ pattern_covariance_matrix( vi, cluster, pattern_level, r_pattern, r, smooth_vi = FALSE, subgroup = NULL, return_list = identical(as.factor(cluster), sort(as.factor(cluster))), check_PD = TRUE ) } \arguments{ \item{vi}{Vector of variances} \item{cluster}{Vector indicating which effects belong to the same cluster. Effects with the same value of `cluster` will be treated as correlated.} \item{pattern_level}{Vector of categories for each effect size, used to determine which entry of the pattern matrix will be used to impute a correlation.} \item{r_pattern}{Patterned correlation matrix with row and column names corresponding to the levels of \code{pattern}.} \item{r}{Vector or numeric value of assumed constant correlation(s) between effect size estimates from each study.} \item{smooth_vi}{Logical indicating whether to smooth the marginal variances by taking the average \code{vi} within each cluster. Defaults to \code{FALSE}.} \item{subgroup}{Vector of category labels describing sub-groups of effects. If non-null, effects that share the same category label and the same cluster will be treated as correlated, but effects with different category labels will be treated as uncorrelated, even if they come from the same cluster.} \item{return_list}{Optional logical indicating whether to return a list of matrices (with one entry per block) or the full variance-covariance matrix.} \item{check_PD}{Optional logical indicating whether to check whether each covariance matrix is positive definite. If \code{TRUE} (the default), the function will display a warning if any covariance matrix is not positive definite.} } \value{ If \code{cluster} is appropriately sorted, then a list of matrices, with one entry per cluster, will be returned by default. If \code{cluster} is out of order, then the full variance-covariance matrix will be returned by default. The output structure can be controlled with the optional \code{return_list} argument. } \description{ `r lifecycle::badge("superseded")` This function is superseded by the \code{\link[metafor]{vcalc}} provided by the \code{metafor} package. Compared to \code{pattern_covariance_matrix}, \code{\link[metafor]{vcalc}} provides many further features, includes a \code{data} argument, and uses syntax that is consistent with other functions in \code{metafor}. \code{pattern_covariance_matrix} calculates a block-diagonal covariance matrix, given the marginal variances, the block structure, and an assumed correlation structure defined by a patterned correlation matrix. } \details{ A block-diagonal variance-covariance matrix (possibly represented as a list of matrices) with a specified correlation structure, defined by a patterned correlation matrix. Let \eqn{v_{ij}}{v-ij} denote the specified variance for effect \eqn{i}{i} in cluster \eqn{j}{j} and \eqn{C_{hij}}{C-hij} be the covariance between effects \eqn{h}{h} and \eqn{i}{i} in cluster \eqn{j}{j}. Let \eqn{p_{ij}}{p-ij} be the level of the pattern variable for effect \eqn{i}{i} in cluster \eqn{j}{j}, taking a value in \eqn{1,...,C}{1,...,C}. A patterned correlation matrix is defined as a set of correlations between pairs of effects taking each possible combination of patterns. Formally, let \eqn{r_{cd}}{r-cd} be the correlation between effects in categories \eqn{c}{c} and \eqn{d}{d}, respectively, where \eqn{r_{cd} = r_{dc}}{r-cd = r-dc}. Then the covariance between effects \eqn{h}{h} and \eqn{i}{i} in cluster \eqn{j}{j} is taken to be \deqn{C_{hij} = \sqrt{v_{hj} v_{ij}} \times r_{p_{hj} p_{ij}}.}{C-hij = sqrt(v-hj v-ij) * r[p-hj, p-ij].} Correlations between effect sizes within the same category are defined by the diagonal values of the pattern matrix, which may take values less than one. Combinations of pattern levels that do not occur in the patterned correlation matrix will be set equal to \code{r}. If \code{smooth_vi = TRUE}, then all of the variances within cluster \eqn{j}{j} will be set equal to the average variance of cluster \eqn{j}{j}, i.e., \deqn{v'_{ij} = \frac{1}{n_j} \sum_{i=1}^{n_j} v_{ij}}{v-ij' = (v-1j + ... + v-nj,j) / n-j} for \eqn{i=1,...,n_j}{i=1,...,n-j} and \eqn{j=1,...,k}{j=1,...,k}. } \examples{ pkgs_available <- requireNamespace("metafor", quietly = TRUE) & requireNamespace("robumeta", quietly = TRUE) if (pkgs_available) { library(metafor) data(oswald2013, package = "robumeta") dat <- escalc(data = oswald2013, measure = "ZCOR", ri = R, ni = N) subset_ids <- unique(dat$Study)[1:20] dat <- subset(dat, Study \%in\% subset_ids) # make a patterned correlation matrix p_levels <- levels(dat$Crit.Cat) r_pattern <- 0.7^as.matrix(dist(1:length(p_levels))) diag(r_pattern) <- seq(0.75, 0.95, length.out = 6) rownames(r_pattern) <- colnames(r_pattern) <- p_levels # impute the covariance matrix using patterned correlations V_list <- pattern_covariance_matrix(vi = dat$vi, cluster = dat$Study, pattern_level = dat$Crit.Cat, r_pattern = r_pattern, smooth_vi = TRUE) # fit a model using imputed covariance matrix MVFE <- rma.mv(yi ~ 0 + Crit.Cat, V = V_list, random = ~ Crit.Cat | Study, data = dat) conf_int(MVFE, vcov = "CR2") } } clubSandwich/man/conf_int.Rd0000644000176200001440000000515614630154051015527 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conf_int.R \name{conf_int} \alias{conf_int} \title{Calculate confidence intervals for all or selected regression coefficients in a fitted model} \usage{ conf_int( obj, vcov, level = 0.95, test = "Satterthwaite", coefs = "All", ..., p_values = FALSE ) } \arguments{ \item{obj}{Fitted model for which to calculate confidence intervals.} \item{vcov}{Variance covariance matrix estimated using \code{vcovCR} or a character string specifying which small-sample adjustment should be used to calculate the variance-covariance.} \item{level}{Desired coverage level for confidence intervals.} \item{test}{Character vector specifying which small-sample corrections to calculate. \code{"z"} returns a z test (i.e., using a standard normal reference distribution). \code{"naive-t"} returns a t test with \code{m - 1} degrees of freedom, where \code{m} is the number of unique clusters. \code{"naive-tp"} returns a t test with \code{m - p} degrees of freedom, where \code{p} is the number of regression coefficients in \code{obj}. \code{"Satterthwaite"} returns a Satterthwaite correction. Unlike in \code{coef_test()}, \code{"saddlepoint"} is not currently supported in \code{conf_int()} because saddlepoint confidence intervals do not have a closed-form solution.} \item{coefs}{Character, integer, or logical vector specifying which coefficients should be tested. The default value \code{"All"} will test all estimated coefficients.} \item{...}{Further arguments passed to \code{\link{vcovCR}}, which are only needed if \code{vcov} is a character string.} \item{p_values}{Logical indicating whether to report p-values. The default value is \code{FALSE}.} } \value{ A data frame containing estimated regression coefficients, standard errors, confidence intervals, and (optionally) p-values. } \description{ \code{conf_int} reports confidence intervals for each coefficient estimate in a fitted linear regression model, using a sandwich estimator for the standard errors and a small sample correction for the critical values. The small-sample correction is based on a Satterthwaite approximation. } \examples{ data("ChickWeight", package = "datasets") lm_fit <- lm(weight ~ Diet * Time, data = ChickWeight) diet_index <- grepl("Diet.:Time", names(coef(lm_fit))) conf_int(lm_fit, vcov = "CR2", cluster = ChickWeight$Chick, coefs = diet_index) V_CR2 <- vcovCR(lm_fit, cluster = ChickWeight$Chick, type = "CR2") conf_int(lm_fit, vcov = V_CR2, level = .99, coefs = diet_index) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.gls.Rd0000644000176200001440000000522614630154051015714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gls.R \name{vcovCR.gls} \alias{vcovCR.gls} \title{Cluster-robust variance-covariance matrix for a gls object.} \usage{ \method{vcovCR}{gls}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional expression or vector indicating which observations belong to the same cluster. If not specified, will be set to \code{getGroups(obj)}.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be the estimated variance-covariance structure of the \code{gls} object.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from a \code{\link[nlme]{gls}} object. } \examples{ if (requireNamespace("nlme", quietly = TRUE)) { library(nlme) data(Ovary, package = "nlme") Ovary$time_int <- 1:nrow(Ovary) lm_AR1 <- gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), data = Ovary, correlation = corAR1(form = ~ time_int | Mare)) vcovCR(lm_AR1, type = "CR2") } } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.ivreg.Rd0000644000176200001440000000726114630154051016244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ivreg.R \name{vcovCR.ivreg} \alias{vcovCR.ivreg} \title{Cluster-robust variance-covariance matrix for an ivreg object.} \usage{ \method{vcovCR}{ivreg}( obj, cluster, type, target = NULL, inverse_var = FALSE, form = "sandwich", ... ) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Expression or vector indicating which observations belong to the same cluster. Required for \code{ivreg} objects.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If a vector, the target matrix is assumed to be diagonal. If not specified, the target is taken to be an identity matrix.} \item{inverse_var}{Not used for \code{ivreg} objects.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from an ivreg object fitted from the \CRANpkg{AER} package or the \CRANpkg{ivreg} package. } \details{ For any "ivreg" objects fitted via the \code{\link[ivreg]{ivreg}} function from the \CRANpkg{ivreg} package, only traditional 2SLS regression method (method = "OLS") is supported. clubSandwich currently cannot support robust-regression methods such as M-estimation (method = "M") or MM-estimation (method = "MM"). } \examples{ if (requireNamespace("AER", quietly = TRUE)) withAutoprint({ library(AER) data("CigarettesSW") Cigs <- within(CigarettesSW, { rprice <- price/cpi rincome <- income/population/cpi tdiff <- (taxs - tax)/cpi }) iv_fit_AER <- AER::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs) vcovCR(iv_fit_AER, cluster = Cigs$state, type = "CR2") coef_test(iv_fit_AER, vcov = "CR2", cluster = Cigs$state) }) pkgs_available <- requireNamespace("AER", quietly = TRUE) & requireNamespace("ivreg", quietly = TRUE) if (pkgs_available) withAutoprint ({ data("CigarettesSW") Cigs <- within(CigarettesSW, { rprice <- price/cpi rincome <- income/population/cpi tdiff <- (taxs - tax)/cpi }) iv_fit_ivreg <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = Cigs) vcovCR(iv_fit_ivreg, cluster = Cigs$state, type = "CR2") coef_test(iv_fit_ivreg, vcov = "CR2", cluster = Cigs$state) }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/dropoutPrevention.Rd0000644000176200001440000000566414630154051017502 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-documentation.R \docType{data} \name{dropoutPrevention} \alias{dropoutPrevention} \title{Dropout prevention/intervention program effects} \format{ A data frame with 385 rows and 18 variables: \describe{ \item{LOR1}{log-odds ratio measuring the intervention effect} \item{varLOR}{estimated sampling variance of the log-odds ratio} \item{studyID}{unique identifier for each study} \item{studySample}{unique identifier for each sample within a study} \item{study_design}{study design (randomized, matched, or non-randomized and unmatched)} \item{outcome}{outcome measure for the intervention effect is estimated (school dropout, school enrollment, graduation, graduation or GED receipt)} \item{evaluator_independence}{degree of evaluator independence (independent, indirect but influential, involved in planning but not delivery, involved in delivery)} \item{implementation_quality}{level of implementation quality (clear problems, possible problems, no apparent problems)} \item{program_site}{Program delivery site (community, mixed, school classroom, school but outside of classroom)} \item{attrition}{Overall attrition (proportion)} \item{group_equivalence}{pretest group-equivalence log-odds ratio} \item{adjusted}{adjusted or unadjusted data used to calculate intervention effect} \item{male_pct}{proportion of the sample that is male} \item{white_pct}{proportion of the sample that is white} \item{average_age}{average age of the sample} \item{duration}{program duration (in weeks)} \item{service_hrs}{program contact hours per week} \item{big_study}{indicator for the 32 studies with 3 or more effect sizes} } } \source{ Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: Effects on school completion and dropout Among school-aged children and youth: A systematic review. _Campbell Systematic Reviews, 7_(1), 1-61. \doi{10.4073/csr.2011.8} } \usage{ dropoutPrevention } \description{ A dataset containing estimated effect sizes, variances, and covariates from a meta-analysis of dropout prevention/intervention program effects, conducted by Wilson et al. (2011). Missing observations were imputed. } \references{ Wilson, S. J., Lipsey, M. W., Tanner-Smith, E., Huang, C. H., & Steinka-Fry, K. T. (2011). Dropout prevention and intervention programs: Effects on school completion and dropout Among school-aged children and youth: A systematic review. _Campbell Systematic Reviews, 7_(1), 1-61. \doi{10.4073/csr.2011.8} Tipton, E., & Pustejovsky, J. E. (2015). Small-sample adjustments for tests of moderators and model fit using robust variance estimation in meta-regression. _Journal of Educational and Behavioral Statistics, 40_(6), 604-634. \doi{10.3102/1076998615606099} } \keyword{datasets} clubSandwich/man/linear_contrast.Rd0000644000176200001440000000735114630154051017116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conf_int.R \name{linear_contrast} \alias{linear_contrast} \title{Calculate confidence intervals and p-values for linear contrasts of regression coefficients in a fitted model} \usage{ linear_contrast( obj, vcov, contrasts, level = 0.95, test = "Satterthwaite", ..., p_values = FALSE ) } \arguments{ \item{obj}{Fitted model for which to calculate confidence intervals.} \item{vcov}{Variance covariance matrix estimated using \code{vcovCR} or a character string specifying which small-sample adjustment should be used to calculate the variance-covariance.} \item{contrasts}{A contrast matrix, or a list of multiple contrast matrices to test. See details and examples.} \item{level}{Desired coverage level for confidence intervals.} \item{test}{Character vector specifying which small-sample corrections to calculate. \code{"z"} returns a z test (i.e., using a standard normal reference distribution). \code{"naive-t"} returns a t test with \code{m - 1} degrees of freedom, where \code{m} is the number of unique clusters. \code{"naive-tp"} returns a t test with \code{m - p} degrees of freedom, where \code{p} is the number of regression coefficients in \code{obj}. \code{"Satterthwaite"} returns a Satterthwaite correction. Unlike in \code{coef_test()}, \code{"saddlepoint"} is not currently supported in \code{conf_int()} because saddlepoint confidence intervals do not have a closed-form solution.} \item{...}{Further arguments passed to \code{\link{vcovCR}}, which are only needed if \code{vcov} is a character string.} \item{p_values}{Logical indicating whether to report p-values. The default value is \code{FALSE}.} } \value{ A data frame containing estimated contrasts, standard errors, confidence intervals, and (optionally) p-values. } \description{ \code{linear_contrast} reports confidence intervals and (optionally) p-values for linear contrasts of regression coefficients from a fitted model, using a sandwich estimator for the standard errors and (optionally) a small sample correction for the critical values. The default small-sample correction is based on a Satterthwaite approximation. } \details{ Constraints can be specified directly as q X p matrices or indirectly through \code{\link{constrain_pairwise}}, \code{\link{constrain_equal}}, or \code{\link{constrain_zero}}. } \examples{ data("ChickWeight", package = "datasets") lm_fit <- lm(weight ~ 0 + Diet + Time:Diet, data = ChickWeight) # Pairwise comparisons of diet-by-time slopes linear_contrast(lm_fit, vcov = "CR2", cluster = ChickWeight$Chick, contrasts = constrain_pairwise("Diet.:Time", reg_ex = TRUE)) if (requireNamespace("carData", quietly = TRUE)) withAutoprint({ data(Duncan, package = "carData") Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) Duncan_fit <- lm(prestige ~ 0 + type + income + type:income + type:education, data=Duncan) # Note that type:income terms are interactions because main effect of income is included # but type:education terms are separate slopes for each unique level of type # Pairwise comparisons of type-by-education slopes linear_contrast(Duncan_fit, vcov = "CR2", cluster = Duncan$cluster, contrasts = constrain_pairwise(":education", reg_ex = TRUE), test = "Satterthwaite") # Pairwise comparisons of type-by-income interactions linear_contrast(Duncan_fit, vcov = "CR2", cluster = Duncan$cluster, contrasts = constrain_pairwise(":income", reg_ex = TRUE, with_zero = TRUE), test = "Satterthwaite") }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.plm.Rd0000644000176200001440000001151414630154051015714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plm.R \name{vcovCR.plm} \alias{vcovCR.plm} \title{Cluster-robust variance-covariance matrix for a plm object.} \usage{ \method{vcovCR}{plm}( obj, cluster, type, target, inverse_var, form = "sandwich", ignore_FE = FALSE, ... ) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional character string, expression, or vector indicating which observations belong to the same cluster. For fixed-effect models that include individual effects or time effects (but not both), the cluster will be taken equal to the included fixed effects if not otherwise specified. Clustering on individuals can also be obtained by specifying the name of the individual index (e.g., \code{cluster = "state"}) or \code{cluster = "individual"}; clustering on time periods can be obtained by specifying the name of the time index (e.g., \code{cluster = "year"}) or \code{cluster = "time"}; if a group index is specified, clustering on groups (in which individuals are nested) can be obtained by specifying the name of the group index or \code{cluster = "group"}. For random-effects models, the cluster will be taken equal to the included random effect identifier if not otherwise specified.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. By default, the target is taken to be an identity matrix for fixed effect models or the estimated compound-symmetric covariance matrix for random effects models.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{ignore_FE}{Optional logical controlling whether fixed effects are ignored when calculating small-sample adjustments in models where fixed effects are estimated through absorption.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from a \code{\link[plm]{plm}} object. } \examples{ if (requireNamespace("plm", quietly = TRUE)) withAutoprint({ library(plm) # fixed effects data("Produc", package = "plm") plm_FE <- plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state","year","region"), effect = "individual", model = "within") vcovCR(plm_FE, type="CR2") vcovCR(plm_FE, type = "CR2", cluster = Produc$region) # clustering on region # random effects plm_RE <- update(plm_FE, model = "random") vcovCR(plm_RE, type = "CR2") vcovCR(plm_RE, type = "CR2", cluster = Produc$region) # clustering on region # nested random effects plm_nested <- update(plm_FE, effect = "nested", model = "random") vcovCR(plm_nested, type = "CR2") # clustering on region }) pkgs_available <- requireNamespace("plm", quietly = TRUE) & requireNamespace("AER", quietly = TRUE) if (pkgs_available) withAutoprint({ # first differencing data(Fatalities, package = "AER") Fatalities <- within(Fatalities, { frate <- 10000 * fatal / pop drinkagec <- cut(drinkage, breaks = 18:22, include.lowest = TRUE, right = FALSE) drinkagec <- relevel(drinkagec, ref = 4) }) plm_FD <- plm(frate ~ beertax + drinkagec + miles + unemp + log(income), data = Fatalities, index = c("state", "year"), model = "fd") vcovHC(plm_FD, method="arellano", type = "sss", cluster = "group") vcovCR(plm_FD, type = "CR1S") vcovCR(plm_FD, type = "CR2") }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.lmerMod.Rd0000644000176200001440000000576114630154051016532 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lmer.R \name{vcovCR.lmerMod} \alias{vcovCR.lmerMod} \title{Cluster-robust variance-covariance matrix for an lmerMod object.} \usage{ \method{vcovCR}{lmerMod}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional expression or vector indicating which observations belong to the same cluster. If not specified, will be set to \code{getGroups(obj)}.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be the estimated variance-covariance structure of the \code{lmerMod} object.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from \code{\link[lme4:merMod-class]{merMod}} object. } \examples{ if (requireNamespace("lme4", quietly = TRUE)) { library(lme4) sleep_fit <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) vcovCR(sleep_fit, type = "CR2") } pkgs_available <- requireNamespace("lme4", quietly = TRUE) & requireNamespace("mlmRev", quietly = TRUE) if (pkgs_available) { data(egsingle, package = "mlmRev") subset_ids <- levels(egsingle$schoolid)[1:10] math_model <- lmer(math ~ year * size + female + black + hispanic + (1 | schoolid) + (1 | childid), data = egsingle, subset = schoolid \%in\% subset_ids) vcovCR(math_model, type = "CR2") } } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.mlm.Rd0000644000176200001440000000472414630154051015716 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mlm.R \name{vcovCR.mlm} \alias{vcovCR.mlm} \title{Cluster-robust variance-covariance matrix for an mlm object.} \usage{ \method{vcovCR}{mlm}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional expression or vector indicating which observations belong to the same cluster. If not specified, each row of the data will be treated as a separate cluster.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be an identity matrix.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from an \code{mlm} object. } \examples{ iris_fit <- lm(cbind(Sepal.Length, Sepal.Width) ~ Species + Petal.Length + Petal.Width, data = iris) Vcluster <- vcovCR(iris_fit, type = "CR2") Vcluster } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/constraint_matrices.Rd0000644000176200001440000000735414630154051020005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Wald_test.R \name{constraint_matrices} \alias{constraint_matrices} \alias{constrain_zero} \alias{constrain_equal} \alias{constrain_pairwise} \title{Create constraint matrices} \usage{ constrain_zero(constraints, coefs, reg_ex = FALSE) constrain_equal(constraints, coefs, reg_ex = FALSE) constrain_pairwise(constraints, coefs, reg_ex = FALSE, with_zero = FALSE) } \arguments{ \item{constraints}{Set of constraints to test. Can be logical (using \code{TRUE} to specify which coefficients to constrain), integer (specify the index of coefficients to constrain), character (specify the names of the coefficients to constrain), or a regular expression.} \item{coefs}{Vector of coefficient estimates, used to determine the column dimension of the constraint matrix. Can be omitted if the function is called inside \code{Wald_test()}.} \item{reg_ex}{Logical indicating whether \code{constraints} should be interpreted as a regular expression. Defaults to \code{FALSE}.} \item{with_zero}{Logical indicating whether coefficients should also be compared to zero. Defaults to \code{FALSE}.} } \value{ A matrix or list of matrices encoding the specified set of constraints. } \description{ Helper functions to create common types of constraint matrices, for use with \code{\link{Wald_test}} to conduct Wald-type tests of linear contrasts from a fitted regression model. } \details{ Constraints can be specified as character vectors, regular expressions (with \code{reg_ex = TRUE}), integer vectors, or logical vectors. \code{constrain_zero()} Creates a matrix that constrains a specified set of coefficients to all be equal to zero. \code{constrain_equal()} Creates a matrix that constrains a specified set of coefficients to all be equal. \code{constrain_pairwise()} Creates a list of constraint matrices consisting of all pairwise comparisons between a specified set of coefficients. If \code{with_zero = TRUE}, then the list will also include a set of constraint matrices comparing each coefficient to zero. } \examples{ if (requireNamespace("carData", quietly = TRUE)) withAutoprint({ data(Duncan, package = "carData") Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) Duncan_fit <- lm(prestige ~ 0 + type + income + type:income + type:education, data=Duncan) # Note that type:income terms are interactions because main effect of income is included # but type:education terms are separate slopes for each unique level of type Duncan_coefs <- coef(Duncan_fit) # The following are all equivalent constrain_zero(constraints = c("typeprof:income","typewc:income"), coefs = Duncan_coefs) constrain_zero(constraints = ":income", coefs = Duncan_coefs, reg_ex = TRUE) constrain_zero(constraints = 5:6, coefs = Duncan_coefs) constrain_zero(constraints = c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, FALSE, FALSE, FALSE), coefs = Duncan_coefs) # The following are all equivalent constrain_equal(c("typebc:education","typeprof:education","typewc:education"), Duncan_coefs) constrain_equal(":education", Duncan_coefs, reg_ex = TRUE) constrain_equal(7:9, Duncan_coefs) constrain_equal(c(FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE,TRUE,TRUE), Duncan_coefs) # Test pairwise equality of the education slopes constrain_pairwise(":education", Duncan_coefs, reg_ex = TRUE) # Test pairwise equality of the income slopes, plus compare against zero constrain_pairwise(":income", Duncan_coefs, reg_ex = TRUE, with_zero = TRUE) }) } \seealso{ \code{\link{Wald_test}} } clubSandwich/man/vcovCR.rma.uni.Rd0000644000176200001440000000564114630154051016501 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rma-uni.R \name{vcovCR.rma.uni} \alias{vcovCR.rma.uni} \title{Cluster-robust variance-covariance matrix for a rma.uni object.} \usage{ \method{vcovCR}{rma.uni}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Expression or vector indicating which observations belong to the same cluster. Required for \code{rma.uni} objects.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be diagonal with entries equal to the estimated marginal variance of the effect sizes.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from a \code{\link[metafor]{rma.uni}} object. } \examples{ pkgs_available <- requireNamespace("metafor", quietly = TRUE) & requireNamespace("metadat", quietly = TRUE) if (pkgs_available) withAutoprint({ library(metafor) data(dat.assink2016, package = "metadat") mfor_fit <- rma.uni(yi ~ year + deltype, vi = vi, data = dat.assink2016) mfor_fit mfor_CR2 <- vcovCR(mfor_fit, type = "CR2", cluster = dat.assink2016$study) mfor_CR2 coef_test(mfor_fit, vcov = mfor_CR2, test = c("Satterthwaite", "saddlepoint")) Wald_test(mfor_fit, constraints = constrain_zero(2:4), vcov = mfor_CR2) }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/vcovCR.Rd0000644000176200001440000001557314630154051015136 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clubSandwich.R \name{vcovCR} \alias{vcovCR} \alias{vcovCR.default} \title{Cluster-robust variance-covariance matrix} \usage{ vcovCR(obj, cluster, type, target, inverse_var, form, ...) \method{vcovCR}{default}( obj, cluster, type, target = NULL, inverse_var = FALSE, form = "sandwich", ... ) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Expression or vector indicating which observations belong to the same cluster. For some classes, the cluster will be detected automatically if not specified.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If a vector, the target matrix is assumed to be diagonal. If not specified, \code{vcovCR} will attempt to infer a value.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. The matrix has several attributes: \describe{ \item{type}{indicates which small-sample adjustment was used} \item{cluster}{contains the factor vector that defines independent clusters} \item{bread}{contains the bread matrix} \item{v_scale}{constant used in scaling the sandwich estimator} \item{est_mats}{contains a list of estimating matrices used to calculate the sandwich estimator} \item{adjustments}{contains a list of adjustment matrices used to calculate the sandwich estimator} \item{target}{contains the working variance-covariance model used to calculate the adjustment matrices. This is needed for calculating small-sample corrections for Wald tests.} } } \description{ This is a generic function, with specific methods defined for \code{\link[stats]{lm}}, \code{\link[plm]{plm}}, \code{\link[stats]{glm}}, \code{\link[nlme]{gls}}, \code{\link[nlme]{lme}}, \code{\link[robumeta]{robu}}, \code{\link[metafor]{rma.uni}}, and \code{\link[metafor]{rma.mv}} objects. \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates. } \details{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates. Several different small sample corrections are available, which run parallel with the "HC" corrections for heteroskedasticity-consistent variance estimators, as implemented in \code{\link[sandwich]{vcovHC}}. The "CR2" adjustment is recommended (Pustejovsky & Tipton, 2017; Imbens & Kolesar, 2016). See Pustejovsky and Tipton (2017) and Cameron and Miller (2015) for further technical details. Available options include: \describe{ \item{"CR0"}{is the original form of the sandwich estimator (Liang & Zeger, 1986), which does not make any small-sample correction.} \item{"CR1"}{multiplies CR0 by \code{m / (m - 1)}, where \code{m} is the number of clusters.} \item{"CR1p"}{multiplies CR0 by \code{m / (m - p)}, where \code{m} is the number of clusters and \code{p} is the number of covariates.} \item{"CR1S"}{multiplies CR0 by \code{(m (N-1)) / [(m - 1)(N - p)]}, where \code{m} is the number of clusters, \code{N} is the total number of observations, and \code{p} is the number of covariates. Some Stata commands use this correction by default.} \item{"CR2"}{is the "bias-reduced linearization" adjustment proposed by Bell and McCaffrey (2002) and further developed in Pustejovsky and Tipton (2017). The adjustment is chosen so that the variance-covariance estimator is exactly unbiased under a user-specified working model.} \item{"CR3"}{approximates the leave-one-cluster-out jackknife variance estimator (Bell & McCaffrey, 2002).} } } \examples{ # simulate design with cluster-dependence m <- 8 cluster <- factor(rep(LETTERS[1:m], 3 + rpois(m, 5))) n <- length(cluster) X <- matrix(rnorm(3 * n), n, 3) nu <- rnorm(m)[cluster] e <- rnorm(n) y <- X \%*\% c(.4, .3, -.3) + nu + e dat <- data.frame(y, X, cluster, row = 1:n) # fit linear model lm_fit <- lm(y ~ X1 + X2 + X3, data = dat) vcov(lm_fit) # cluster-robust variance estimator with CR2 small-sample correction vcovCR(lm_fit, cluster = dat$cluster, type = "CR2") # compare small-sample adjustments CR_types <- paste0("CR",c("0","1","1S","2","3")) sapply(CR_types, function(type) sqrt(diag(vcovCR(lm_fit, cluster = dat$cluster, type = type)))) } \references{ Bell, R. M., & McCaffrey, D. F. (2002). Bias reduction in standard errors for linear regression with multi-stage samples. Survey Methodology, 28(2), 169-181. Cameron, A. C., & Miller, D. L. (2015). A Practitioner's Guide to Cluster-Robust Inference. \emph{Journal of Human Resources, 50}(2), 317-372. \doi{10.3368/jhr.50.2.317} Imbens, G. W., & Kolesar, M. (2016). Robust standard errors in small samples: Some practical advice. \emph{Review of Economics and Statistics, 98}(4), 701-712. \doi{10.1162/rest_a_00552} Liang, K.-Y., & Zeger, S. L. (1986). Longitudinal data analysis using generalized linear models. \emph{Biometrika, 73}(1), 13-22. \doi{10.1093/biomet/73.1.13} Pustejovsky, J. E. & Tipton, E. (2018). Small sample methods for cluster-robust variance estimation and hypothesis testing in fixed effects models. \emph{Journal of Business and Economic Statistics, 36}(4), 672-683. \doi{10.1080/07350015.2016.1247004} } \seealso{ \code{\link{vcovCR.lm}}, \code{\link{vcovCR.plm}}, \code{\link{vcovCR.glm}}, \code{\link{vcovCR.gls}}, \code{\link{vcovCR.lme}}, \code{\link{vcovCR.lmerMod}}, \code{\link{vcovCR.robu}}, \code{\link{vcovCR.rma.uni}}, \code{\link{vcovCR.rma.mv}} } clubSandwich/man/vcovCR.glm.Rd0000644000176200001440000000530514630154051015704 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/glm.R \name{vcovCR.glm} \alias{vcovCR.glm} \title{Cluster-robust variance-covariance matrix for a glm object.} \usage{ \method{vcovCR}{glm}( obj, cluster, type, target = NULL, inverse_var = NULL, form = "sandwich", ... ) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Expression or vector indicating which observations belong to the same cluster. Required for \code{glm} objects.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If a vector, the target matrix is assumed to be diagonal. If not specified, the target is taken to be the estimated variance function.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from an \code{\link{glm}} object. } \examples{ if (requireNamespace("geepack", quietly = TRUE)) { data(dietox, package = "geepack") dietox$Cu <- as.factor(dietox$Cu) weight_fit <- glm(Weight ~ Cu * poly(Time, 3), data=dietox, family = "quasipoisson") V_CR <- vcovCR(weight_fit, cluster = dietox$Pig, type = "CR2") coef_test(weight_fit, vcov = V_CR, test = "Satterthwaite") } } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/impute_covariance_matrix.Rd0000644000176200001440000001341314635054543021016 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rma-mv.R \name{impute_covariance_matrix} \alias{impute_covariance_matrix} \title{Impute a block-diagonal covariance matrix} \usage{ impute_covariance_matrix( vi, cluster, r, ti, ar1, smooth_vi = FALSE, subgroup = NULL, return_list = identical(as.factor(cluster), sort(as.factor(cluster))), check_PD = TRUE ) } \arguments{ \item{vi}{Vector of variances} \item{cluster}{Vector indicating which effects belong to the same cluster. Effects with the same value of `cluster` will be treated as correlated.} \item{r}{Vector or numeric value of assumed constant correlation(s) between effect size estimates from each study.} \item{ti}{Vector of time-points describing temporal spacing of effects, for use with auto-regressive correlation structures.} \item{ar1}{Vector or numeric value of assumed AR(1) auto-correlation(s) between effect size estimates from each study. If specified, then \code{ti} argument must be specified.} \item{smooth_vi}{Logical indicating whether to smooth the marginal variances by taking the average \code{vi} within each cluster. Defaults to \code{FALSE}.} \item{subgroup}{Vector of category labels describing sub-groups of effects. If non-null, effects that share the same category label and the same cluster will be treated as correlated, but effects with different category labels will be treated as uncorrelated, even if they come from the same cluster.} \item{return_list}{Optional logical indicating whether to return a list of matrices (with one entry per block) or the full variance-covariance matrix.} \item{check_PD}{Optional logical indicating whether to check whether each covariance matrix is positive definite. If \code{TRUE} (the default), the function will display a warning if any covariance matrix is not positive definite.} } \value{ If \code{cluster} is appropriately sorted, then a list of matrices, with one entry per cluster, will be returned by default. If \code{cluster} is out of order, then the full variance-covariance matrix will be returned by default. The output structure can be controlled with the optional \code{return_list} argument. } \description{ `r lifecycle::badge("superseded")` This function is superseded by the \code{\link[metafor]{vcalc}} provided by the \code{metafor} package. Compared to \code{impute_covariance_matrix}, \code{\link[metafor]{vcalc}} provides many further features, includes a \code{data} argument, and uses syntax that is consistent with other functions in \code{metafor}. \code{impute_covariance_matrix} calculates a block-diagonal covariance matrix, given the marginal variances, the block structure, and an assumed correlation structure. Can be used to create compound-symmetric structures, AR(1) auto-correlated structures, or combinations thereof. } \details{ A block-diagonal variance-covariance matrix (possibly represented as a list of matrices) with a specified structure. The structure depends on whether the \code{r} argument, \code{ar1} argument, or both arguments are specified. Let \eqn{v_{ij}}{v-ij} denote the specified variance for effect \eqn{i}{i} in cluster \eqn{j}{j} and \eqn{C_{hij}}{C-hij} be the covariance between effects \eqn{h}{h} and \eqn{i}{i} in cluster \eqn{j}{j}. \itemize{ \item{If only \code{r} is specified, each block of the variance-covariance matrix will have a constant (compound symmetric) correlation, so that \deqn{C_{hij} = r_j \sqrt{v_{hj} v_{ij},}}{C-hij = r-j * sqrt(v-hj v-ij),} where \eqn{r_j}{r-j} is the specified correlation for cluster \eqn{j}{j}. If only a single value is given in \code{r}, then it will be used for every cluster.} \item{If only \code{ar1} is specified, each block of the variance-covariance matrix will have an AR(1) auto-correlation structure, so that \deqn{C_{hij} = \phi_j^{|t_{hj}- t_{ij}|} \sqrt{v_{hj} v_{ij},}}{C-hij = (ar1-j)^|t-hj - t-ij| * sqrt(v-hj v-ij),} where \eqn{\phi_j}{ar1-j} is the specified auto-correlation for cluster \eqn{j}{j} and \eqn{t_{hj}}{t-hj} and \eqn{t_{ij}}{t-ij} are specified time-points corresponding to effects \eqn{h}{h} and \eqn{i}{i} in cluster \eqn{j}{j}. If only a single value is given in \code{ar1}, then it will be used for every cluster.} \item{If both \code{r} and \code{ar1} are specified, each block of the variance-covariance matrix will have combination of compound symmetric and an AR(1) auto-correlation structures, so that \deqn{C_{hij} = \left[r_j + (1 - r_j)\phi_j^{|t_{hj} - t_{ij}|}\right] \sqrt{v_{hj} v_{ij},}}{C-hij = [r-j + (1 - r-j)(ar1-j)^|t-hj - t-ij|] * sqrt(v-hj v-ij),} where \eqn{r_j}{r-j} is the specified constant correlation for cluster \eqn{j}{j}, \eqn{\phi_j}{ar1-j} is the specified auto-correlation for cluster \eqn{j}{j} and \eqn{t_{hj}}{t-hj} and \eqn{t_{ij}}{t-ij} are specified time-points corresponding to effects \eqn{h}{h} and \eqn{i}{i} in cluster \eqn{j}{j}. If only single values are given in \code{r} or \code{ar1}, they will be used for every cluster.} } If \code{smooth_vi = TRUE}, then all of the variances within cluster \eqn{j}{j} will be set equal to the average variance of cluster \eqn{j}{j}, i.e., \deqn{v'_{ij} = \frac{1}{n_j} \sum_{i=1}^{n_j} v_{ij}}{v-ij' = (v-1j + ... + v-nj,j) / n-j} for \eqn{i=1,...,n_j}{i=1,...,n-j} and \eqn{j=1,...,k}{j=1,...,k}. } \examples{ if (requireNamespace("metafor", quietly = TRUE)) { library(metafor) # Constant correlation data(SATcoaching) V_list <- impute_covariance_matrix(vi = SATcoaching$V, cluster = SATcoaching$study, r = 0.66) MVFE <- rma.mv(d ~ 0 + test, V = V_list, data = SATcoaching) conf_int(MVFE, vcov = "CR2", cluster = SATcoaching$study) } } clubSandwich/man/AchievementAwardsRCT.Rd0000644000176200001440000000404014630154051017662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-documentation.R \docType{data} \name{AchievementAwardsRCT} \alias{AchievementAwardsRCT} \title{Achievement Awards Demonstration program} \format{ A data frame with 16526 rows and 21 variables: \describe{ \item{school_id}{Fictitious school identification number} \item{school_type}{Factor identifying the school type (Arab religious, Jewish religious, Jewish secular)} \item{pair}{Number of treatment pair. Note that 7 is a triple.} \item{treated}{Indicator for whether school was in treatment group} \item{year}{Cohort year} \item{student_id}{Fictitious student identification number} \item{sex}{Factor identifying student sex} \item{siblings}{Number of siblings} \item{immigrant}{Indicator for immigrant status} \item{father_ed}{Father's level of education} \item{mother_ed}{Mother's level of education} \item{Bagrut_status}{Indicator for Bagrut attainment} \item{attempted}{Number of Bagrut units attempted} \item{awarded}{Number of Bagrut units awarded} \item{achv_math}{Indicator for satisfaction of math requirement} \item{achv_english}{Indicator for satisfaction of English requirement} \item{achv_hebrew}{Indicator for satisfaction of Hebrew requirement} \item{lagscore}{Lagged Bagrut score} \item{qrtl}{Quartile within distribution of lagscore, calculated by cohort and sex} \item{half}{Lower or upper half within distribution of lagscore, calculated by cohort and sex} } } \source{ \href{https://economics.mit.edu/people/faculty/josh-angrist/angrist-data-archive}{Angrist Data Archive} } \usage{ AchievementAwardsRCT } \description{ Data from a randomized trial of the Achievement Awards Demonstration program, reported in Angrist & Lavy (2009). } \references{ Angrist, J. D., & Lavy, V. (2009). The effects of high stakes high school achievement awards : Evidence from a randomized trial. \emph{American Economic Review, 99}(4), 1384-1414. \doi{10.1257/aer.99.4.1384} } \keyword{datasets} clubSandwich/man/vcovCR.rma.mv.Rd0000644000176200001440000000610014630154051016317 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rma-mv.R \name{vcovCR.rma.mv} \alias{vcovCR.rma.mv} \title{Cluster-robust variance-covariance matrix for a rma.mv object.} \usage{ \method{vcovCR}{rma.mv}(obj, cluster, type, target, inverse_var, form = "sandwich", ...) } \arguments{ \item{obj}{Fitted model for which to calculate the variance-covariance matrix} \item{cluster}{Optional expression or vector indicating which observations belong to the same cluster. If not specified, will be set to the factor in the random-effects structure with the fewest distinct levels. Caveat emptor: the function does not check that the random effects are nested.} \item{type}{Character string specifying which small-sample adjustment should be used, with available options \code{"CR0"}, \code{"CR1"}, \code{"CR1p"}, \code{"CR1S"}, \code{"CR2"}, or \code{"CR3"}. See "Details" section of \code{\link{vcovCR}} for further information.} \item{target}{Optional matrix or vector describing the working variance-covariance model used to calculate the \code{CR2} and \code{CR4} adjustment matrices. If not specified, the target is taken to be the estimated variance-covariance structure of the \code{rma.mv} object.} \item{inverse_var}{Optional logical indicating whether the weights used in fitting the model are inverse-variance. If not specified, \code{vcovCR} will attempt to infer a value.} \item{form}{Controls the form of the returned matrix. The default \code{"sandwich"} will return the sandwich variance-covariance matrix. Alternately, setting \code{form = "meat"} will return only the meat of the sandwich and setting \code{form = B}, where \code{B} is a matrix of appropriate dimension, will return the sandwich variance-covariance matrix calculated using \code{B} as the bread. \code{form = "estfun"} will return the (appropriately scaled) estimating function, the transposed crossproduct of which is equal to the sandwich variance-covariance matrix.} \item{...}{Additional arguments available for some classes of objects.} } \value{ An object of class \code{c("vcovCR","clubSandwich")}, which consists of a matrix of the estimated variance of and covariances between the regression coefficient estimates. } \description{ \code{vcovCR} returns a sandwich estimate of the variance-covariance matrix of a set of regression coefficient estimates from a \code{\link[metafor]{rma.mv}} object. } \examples{ pkgs_available <- requireNamespace("metafor", quietly = TRUE) & requireNamespace("metadat", quietly = TRUE) if (pkgs_available) withAutoprint({ library(metafor) data(dat.assink2016, package = "metadat") mfor_fit <- rma.mv(yi ~ year + deltype, V = vi, random = ~ 1 | study / esid, data = dat.assink2016) mfor_fit mfor_CR2 <- vcovCR(mfor_fit, type = "CR2") mfor_CR2 coef_test(mfor_fit, vcov = mfor_CR2, test = c("Satterthwaite", "saddlepoint")) Wald_test(mfor_fit, constraints = constrain_zero(3:4), vcov = mfor_CR2) }) } \seealso{ \code{\link{vcovCR}} } clubSandwich/man/findCluster.rma.mv.Rd0000644000176200001440000000153514630154051017406 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rma-mv.R \name{findCluster.rma.mv} \alias{findCluster.rma.mv} \title{Detect cluster structure of an rma.mv object} \usage{ findCluster.rma.mv(obj) } \arguments{ \item{obj}{A fitted \code{rma.mv} object.} } \value{ A a vector of ID variables for the highest level of clustering in \code{obj}. } \description{ \code{findCluster.rma.mv} returns a vector of ID variables for the highest level of clustering in a fitted \code{rma.mv} model. } \examples{ if (requireNamespace("metafor", quietly = TRUE)) { library(metafor) data(dat.assink2016, package = "metadat") mfor_fit <- rma.mv(yi ~ year + deltype, V = vi, random = ~ 1 | study / esid, data = dat.assink2016) findCluster.rma.mv(mfor_fit) } } clubSandwich/man/Wald_test.Rd0000644000176200001440000000641314630154051015653 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Wald_test.R \name{Wald_test} \alias{Wald_test} \title{Test parameter constraints in a fitted linear regression model} \usage{ Wald_test(obj, constraints, vcov, test = "HTZ", tidy = FALSE, ...) } \arguments{ \item{obj}{Fitted model for which to calculate Wald tests.} \item{constraints}{List of one or more constraints to test. See details and examples.} \item{vcov}{Variance covariance matrix estimated using \code{vcovCR} or a character string specifying which small-sample adjustment should be used to calculate the variance-covariance.} \item{test}{Character vector specifying which small-sample correction(s) to calculate. The following corrections are available: \code{"chi-sq"}, \code{"Naive-F"}, \code{"Naive-Fp"}, \code{"HTA"}, \code{"HTB"}, \code{"HTZ"}, \code{"EDF"}, \code{"EDT"}. Default is \code{"HTZ"}.} \item{tidy}{Logical value controlling whether to tidy the test results. If \code{constraints} is a list with multiple constraints, the result will be coerced into a data frame when \code{tidy = TRUE}.} \item{...}{Further arguments passed to \code{\link{vcovCR}}, which are only needed if \code{vcov} is a character string.} } \value{ A list of test results. } \description{ \code{Wald_test} reports Wald-type tests of linear contrasts from a fitted linear regression model, using a sandwich estimator for the variance-covariance matrix and a small sample correction for the p-value. Several different small-sample corrections are available. } \details{ Constraints can be specified directly as q X p matrices or indirectly through \code{\link{constrain_equal}}, \code{\link{constrain_zero}}, or \code{\link{constrain_pairwise}} } \examples{ if (requireNamespace("carData", quietly = TRUE)) withAutoprint({ data(Duncan, package = "carData") Duncan$cluster <- sample(LETTERS[1:8], size = nrow(Duncan), replace = TRUE) Duncan_fit <- lm(prestige ~ 0 + type + income + type:income + type:education, data=Duncan) # Note that type:income terms are interactions because main effect of income is included # but type:education terms are separate slopes for each unique level of type # Test equality of intercepts Wald_test(Duncan_fit, constraints = constrain_equal(1:3), vcov = "CR2", cluster = Duncan$cluster) # Test equality of type-by-education slopes Wald_test(Duncan_fit, constraints = constrain_equal(":education", reg_ex = TRUE), vcov = "CR2", cluster = Duncan$cluster) # Pairwise comparisons of type-by-education slopes Wald_test(Duncan_fit, constraints = constrain_pairwise(":education", reg_ex = TRUE), vcov = "CR2", cluster = Duncan$cluster) # Test type-by-income interactions Wald_test(Duncan_fit, constraints = constrain_zero(":income", reg_ex = TRUE), vcov = "CR2", cluster = Duncan$cluster) # Pairwise comparisons of type-by-income interactions Wald_test(Duncan_fit, constraints = constrain_pairwise(":income", reg_ex = TRUE, with_zero = TRUE), vcov = "CR2", cluster = Duncan$cluster) }) } \seealso{ \code{\link{vcovCR}}, \code{\link{constrain_equal}}, \code{\link{constrain_zero}}, \code{\link{constrain_pairwise}} } clubSandwich/DESCRIPTION0000644000176200001440000000421414635072452014377 0ustar liggesusersPackage: clubSandwich Title: Cluster-Robust (Sandwich) Variance Estimators with Small-Sample Corrections Version: 0.5.11 Authors@R: person("James", "Pustejovsky", email = "jepusto@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-0591-9465")) Description: Provides several cluster-robust variance estimators (i.e., sandwich estimators) for ordinary and weighted least squares linear regression models, including the bias-reduced linearization estimator introduced by Bell and McCaffrey (2002) and developed further by Pustejovsky and Tipton (2017) . The package includes functions for estimating the variance- covariance matrix and for testing single- and multiple- contrast hypotheses based on Wald test statistics. Tests of single regression coefficients use Satterthwaite or saddle-point corrections. Tests of multiple- contrast hypotheses use an approximation to Hotelling's T-squared distribution. Methods are provided for a variety of fitted models, including lm() and mlm objects, glm(), geeglm() (from package 'geepack'), ivreg() (from package 'AER'), ivreg() (from package 'ivreg' when estimated by ordinary least squares), plm() (from package 'plm'), gls() and lme() (from 'nlme'), lmer() (from `lme4`), robu() (from 'robumeta'), and rma.uni() and rma.mv() (from 'metafor'). URL: http://jepusto.github.io/clubSandwich/ BugReports: https://github.com/jepusto/clubSandwich/issues Depends: R (>= 3.0.0) License: GPL-3 VignetteBuilder: knitr LazyData: true Imports: stats, sandwich, lifecycle Suggests: Formula, knitr, carData, geepack, metafor, metadat, robumeta, nlme, mlmRev, AER, plm (>= 1.6-4), Matrix, lme4, zoo, testthat, rmarkdown, covr, ivreg RoxygenNote: 7.3.1 Encoding: UTF-8 Language: en-US NeedsCompilation: no Packaged: 2024-06-20 17:42:32 UTC; jamespustejovsky Author: James Pustejovsky [aut, cre] () Maintainer: James Pustejovsky Repository: CRAN Date/Publication: 2024-06-20 18:30:02 UTC