Merge pull request #45 from nhejazi/44-missing-obs-weights

add back obs_weights to est_tml()
nhejazi · Mar 4, 2024 · a7cecb5 · a7cecb5
2 parents 15f938f + fc1f674
commit a7cecb5
Show file tree

Hide file tree

Showing 3 changed files with 15 additions and 5 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: medoutcon
 Title: Efficient Natural and Interventional Causal Mediation Analysis
-Version: 0.2.0
+Version: 0.2.1
 Authors@R: c(
     person("Nima", "Hejazi", email = "nh@nimahejazi.org",
            role = c("aut", "cre", "cph"),

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,8 @@
+# medoutcon 0.2.1
+
+* Fixes issue affecting weighted TMLEs that introduced itself during
+  previous update to `est_tml()`.
+
 # medoutcon 0.2.0
 
 * Added support for a semiparametric correction for outcome-dependent two-phase

diff --git a/R/estimators.R b/R/estimators.R
@@ -776,7 +776,7 @@ est_tml <- function(data,
         weights_b_tilt <- as.numeric(data[R == 1, A] == contrast[1]) / g_prime *
           as.numeric(data[R == 1, two_phase_weights])
       } else {
-        weights_b_tilt <- (data$A == contrast[1]) / g_prime
+        weights_b_tilt <- data$obs_weights * (data$A == contrast[1]) / g_prime
       }
 
       suppressWarnings(
@@ -829,7 +829,7 @@ est_tml <- function(data,
          weights_q_tilt <- as.numeric(data[R == 1, A] == contrast[1]) /
            g_prime * as.numeric(data[R == 1, two_phase_weights])
       } else {
-        weights_q_tilt <- (data$A == contrast[1]) / g_prime
+        weights_q_tilt <- data$obs_weights * (data$A == contrast[1]) / g_prime
       }
       suppressWarnings(
         q_tilt_fit <- stats::glm(
@@ -906,15 +906,20 @@ est_tml <- function(data,
     stats::qlogis()
 
   # fit tilting model for substitution estimator
+  if (tilt_two_phase_weights) {
+    weights_v_tilt <- (as.numeric(data[R == 1, A]) == contrast[2]) / g_star *
+        (as.numeric(data[R == 1, two_phase_weights]))
+  } else {
+    weights_v_tilt <- data$obs_weights * (data$A == contrast[2]) / g_star
+  }
   suppressWarnings(
     v_tilt_fit <- stats::glm(
       stats::as.formula("v_pseudo ~ offset(v_star_logit)"),
       data = data.table::as.data.table(list(
         v_pseudo = v_pseudo,
         v_star_logit = v_star_logit
       )),
-      weights = (as.numeric(data[R == 1, A]) == contrast[2]) / g_star *
-        (as.numeric(data[R == 1, two_phase_weights])),
+      weights = weights_v_tilt,
       family = "binomial",
       start = 0
     )