counterfactual mean outcome under a vector of pre-specified treatment probabilities

NAMESPACE

@@ -11,6 +11,7 @@ export(LF_static)
 export(LF_targeted)
 export(Likelihood)
 export(Likelihood_cache)
+export(Param_ADSM)
 export(Param_ATC)
 export(Param_ATE)
 export(Param_ATT)
@@ -56,6 +57,7 @@ export(tmle3)
 export(tmle3_Fit)
 export(tmle3_Node)
 export(tmle3_Spec)
+export(tmle3_Spec_ADSM)
 export(tmle3_Spec_ATC)
 export(tmle3_Spec_ATE)
 export(tmle3_Spec_ATT)
@@ -70,6 +72,7 @@ export(tmle3_Task)
 export(tmle3_Update)
 export(tmle3_Update_survival)
 export(tmle3_vim)
+export(tmle_ADSM)
 export(tmle_ATC)
 export(tmle_ATE)
 export(tmle_ATT)
@@ -113,5 +116,11 @@ importFrom(stats,quantile)
 importFrom(stats,var)
 importFrom(stringr,str_replace_all)
 importFrom(stringr,str_split)
+importFrom(tmle3,Param_TSM)
+importFrom(tmle3,Targeted_Likelihood)
+importFrom(tmle3,define_lf)
+importFrom(tmle3,point_tx_likelihood)
+importFrom(tmle3,tmle3_Spec)
+importFrom(tmle3,tmle3_Update)
 importFrom(utils,packageVersion)
 importFrom(uuid,UUIDgenerate)

R/Param_ADATE.R

@@ -0,0 +1,165 @@
+#' Average Treatment Effect under Adaptive Design
+#'
+#' Parameter definition for Average Treatment Effect under Adaptive Design (ADATE): $P_{n,W}[E(Y|A=1,W)-E(Y|A=0,W)]$. Currently supports adaptive design for BINARY intervention nodes.
+#' @importFrom R6 R6Class
+#' @importFrom uuid UUIDgenerate
+#' @importFrom methods is
+#' @family Parameters
+#' @keywords data
+#'
+#' @return \code{Param_base} object
+#'
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Constructor:
+#'   \code{define_param(Param_ATT, observed_likelihood, intervention_list, ..., outcome_node)}
+#'
+#'   \describe{
+#'     \item{\code{observed_likelihood}}{A \code{\link{Likelihood}} corresponding to the observed likelihood
+#'     }
+#'     \item{\code{intervention_list_treatment}}{A list of objects inheriting from \code{\link{LF_base}}, representing the treatment intervention.
+#'     }
+#'     \item{\code{intervention_list_control}}{A list of objects inheriting from \code{\link{LF_base}}, representing the control intervention.
+#'     }
+#'     \item{\code{g_treat}}{vector, the actual probability of A that corresponds to treatment
+#'     }
+
+#'     \item{\code{...}}{Not currently used.
+#'     }
+#'     \item{\code{outcome_node}}{character, the name of the node that should be treated as the outcome
+#'     }
+#'     }
+#'
+
+#' @section Fields:
+#' \describe{
+#'     \item{\code{cf_likelihood_treatment}}{the counterfactual likelihood for the treatment
+#'     }
+#'     \item{\code{cf_likelihood_control}}{the counterfactual likelihood for the control
+#'     }
+#'     \item{\code{g_treat}}{the actual probability of A that corresponds to treatment
+#'     }
+#'     \item{\code{intervention_list_treatment}}{A list of objects inheriting from \code{\link{LF_base}}, representing the treatment intervention
+#'     }
+#'     \item{\code{intervention_list_control}}{A list of objects inheriting from \code{\link{LF_base}}, representing the control intervention
+#'     }
+#' }
+#' @export
+Param_ADATE <- R6Class(
+  classname = "Param_ADATE",
+  portable = TRUE,
+  class = TRUE,
+  inherit = Param_base,
+  public = list(
+    initialize = function(observed_likelihood, intervention_list_treatment, intervention_list_control, g_treat, outcome_node = "Y") {
+      super$initialize(observed_likelihood, list(), outcome_node)
+      if (!is.null(observed_likelihood$censoring_nodes[[outcome_node]])) {
+        # add delta_Y=0 to intervention lists
+        outcome_censoring_node <- observed_likelihood$censoring_nodes[[outcome_node]]
+        censoring_intervention <- define_lf(LF_static, outcome_censoring_node, value = 1)
+        intervention_list_treatment <- c(intervention_list_treatment, censoring_intervention)
+        intervention_list_control <- c(intervention_list_control, censoring_intervention)
+      }
+      private$.g_treat <- g_treat
+
+      private$.cf_likelihood_treatment <- CF_Likelihood$new(observed_likelihood, intervention_list_treatment)
+      private$.cf_likelihood_control <- CF_Likelihood$new(observed_likelihood, intervention_list_control)
+    },
+    clever_covariates = function(tmle_task = NULL, fold_number = "full") {
+      if (is.null(tmle_task)) {
+        tmle_task <- self$observed_likelihood$training_task
+      }
+
+      intervention_nodes <- union(names(self$intervention_list_treatment), names(self$intervention_list_control))
+
+      pA <- self$observed_likelihood$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_treatment <- self$cf_likelihood_treatment$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_control <- self$cf_likelihood_control$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+
+      g_treat <- self$g_treat
+
+      HA_treatment <- cf_pA_treatment / g_treat
+      HA_control <- cf_pA_control / (1 - g_treat)
+
+      # collapse across multiple intervention nodes
+      if (!is.null(ncol(HA_treatment)) && ncol(HA_treatment) > 1) {
+        HA_treatment <- apply(HA_treatment, 1, prod)
+      }
+
+      # collapse across multiple intervention nodes
+      if (!is.null(ncol(HA_control)) && ncol(HA_control) > 1) {
+        HA_control <- apply(HA_control, 1, prod)
+      }
+
+      HA <- HA_treatment - HA_control
+
+      HA <- bound(HA, c(-40, 40))
+      return(list(Y = HA))
+    },
+    estimates = function(tmle_task = NULL, fold_number = "full") {
+      if (is.null(tmle_task)) {
+        tmle_task <- self$observed_likelihood$training_task
+      }
+
+      intervention_nodes <- union(names(self$intervention_list_treatment), names(self$intervention_list_control))
+
+      # clever_covariates happen here (for this param) only, but this is repeated computation
+      HA <- self$clever_covariates(tmle_task, fold_number)[[self$outcome_node]]
+
+
+      # todo: make sure we support updating these params
+      pA <- self$observed_likelihood$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_treatment <- self$cf_likelihood_treatment$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_control <- self$cf_likelihood_control$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+
+      # todo: extend for stochastic
+      cf_task_treatment <- self$cf_likelihood_treatment$enumerate_cf_tasks(tmle_task)[[1]]
+      cf_task_control <- self$cf_likelihood_control$enumerate_cf_tasks(tmle_task)[[1]]
+
+      Y <- tmle_task$get_tmle_node(self$outcome_node, impute_censoring = TRUE)
+
+      EY <- self$observed_likelihood$get_likelihood(tmle_task, self$outcome_node, fold_number)
+      EY1 <- self$observed_likelihood$get_likelihood(cf_task_treatment, self$outcome_node, fold_number)
+      EY0 <- self$observed_likelihood$get_likelihood(cf_task_control, self$outcome_node, fold_number)
+
+      psi <- mean(EY1 - EY0)
+      IC <- HA * (Y - EY)
+
+      result <- list(psi = psi, IC = IC)
+      return(result)
+    }
+  ),
+  active = list(
+    name = function() {
+      # param_form <- sprintf("ATE[%s_{%s}-%s_{%s}]", self$outcome_node, self$cf_likelihood_treatment$name, self$outcome_node, self$cf_likelihood_control$name)
+      param_form <- "ADATE[Y]"
+      return(param_form)
+    },
+    g_treat = function(){
+      return (private$.g_treat)
+    },
+    cf_likelihood_treatment = function() {
+      return(private$.cf_likelihood_treatment)
+    },
+    cf_likelihood_control = function() {
+      return(private$.cf_likelihood_control)
+    },
+    intervention_list_treatment = function() {
+      return(self$cf_likelihood_treatment$intervention_list)
+    },
+    intervention_list_control = function() {
+      return(self$cf_likelihood_control$intervention_list)
+    },
+    update_nodes = function() {
+      return(c(self$outcome_node))
+    }
+  ),
+  private = list(
+    .type = "ADATE",
+    .g_treat = NULL,
+    .cf_likelihood_treatment = NULL,
+    .cf_likelihood_control = NULL,
+    .supports_outcome_censoring = TRUE
+  )
+)
+

R/Param_ADSM.R

@@ -0,0 +1,180 @@
+#' Adaptive Design Specific Mean
+#'
+#' Parameter definition for the Adaptive Design Specific Mean (ADSM): $P_{n,W}[E_{g_adapt}(Y|A=a|W)]$. Currently supports adaptive design for BINARY intervention nodes.
+#' @importFrom R6 R6Class
+#' @importFrom uuid UUIDgenerate
+#' @importFrom methods is
+#' @family Parameters
+#' @keywords data
+#'
+#' @return \code{Param_base} object
+#'
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Constructor:
+#'   \code{define_param(Param_ATT, observed_likelihood, intervention_list, ..., outcome_node)}
+#'
+#'   \describe{
+#'     \item{\code{observed_likelihood}}{A \code{\link{Likelihood}} corresponding to the observed likelihood
+#'     }
+#'     \item{\code{intervention_list_treatment}}{A list of objects inheriting from \code{\link{LF_base}}, representing the treatment intervention.
+#'     }
+#'     \item{\code{intervention_list_control}}{A list of objects inheriting from \code{\link{LF_base}}, representing the control intervention.
+#'     }
+#'     \item{\code{g_treat}}{vector, the actual probability of A that corresponds to treatment
+#'     }
+#'     \item{\code{g_adapt}}{vector, the probability of A that corresponds to treatment under a candidate adaptive design
+#'     }
+
+#'     \item{\code{...}}{Not currently used.
+#'     }
+#'     \item{\code{outcome_node}}{character, the name of the node that should be treated as the outcome
+#'     }
+#'     }
+#'
+
+#' @section Fields:
+#' \describe{
+#'     \item{\code{cf_likelihood_treatment}}{the counterfactual likelihood for the treatment
+#'     }
+#'     \item{\code{cf_likelihood_control}}{the counterfactual likelihood for the control
+#'     }
+#'     \item{\code{g_treat}}{the actual probability of A that corresponds to treatment
+#'     }
+#'     \item{\code{g_adapt}}{the probability of A that corresponds to treatment under a candidate adaptive design
+#'     }
+#'     \item{\code{intervention_list_treatment}}{A list of objects inheriting from \code{\link{LF_base}}, representing the treatment intervention
+#'     }
+#'     \item{\code{intervention_list_control}}{A list of objects inheriting from \code{\link{LF_base}}, representing the control intervention
+#'     }
+#' }
+#' @export
+Param_ADSM <- R6Class(
+  classname = "Param_ADSM",
+  portable = TRUE,
+  class = TRUE,
+  inherit = Param_base,
+  public = list(
+    initialize = function(observed_likelihood, intervention_list_treatment, intervention_list_control, g_treat, g_adapt, outcome_node = "Y") {
+      super$initialize(observed_likelihood, list(), outcome_node)
+      if (!is.null(observed_likelihood$censoring_nodes[[outcome_node]])) {
+        # add delta_Y=0 to intervention lists
+        outcome_censoring_node <- observed_likelihood$censoring_nodes[[outcome_node]]
+        censoring_intervention <- define_lf(LF_static, outcome_censoring_node, value = 1)
+        intervention_list_treatment <- c(intervention_list_treatment, censoring_intervention)
+        intervention_list_control <- c(intervention_list_control, censoring_intervention)
+      }
+      private$.g_treat <- g_treat
+      private$.g_adapt <- g_adapt
+
+      private$.cf_likelihood_treatment <- CF_Likelihood$new(observed_likelihood, intervention_list_treatment)
+      private$.cf_likelihood_control <- CF_Likelihood$new(observed_likelihood, intervention_list_control)
+    },
+    clever_covariates = function(tmle_task = NULL, fold_number = "full") {
+      if (is.null(tmle_task)) {
+        tmle_task <- self$observed_likelihood$training_task
+      }
+
+      intervention_nodes <- union(names(self$intervention_list_treatment), names(self$intervention_list_control))
+
+      pA <- self$observed_likelihood$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_treatment <- self$cf_likelihood_treatment$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_control <- self$cf_likelihood_control$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+
+      g_treat <- self$g_treat
+      g_adapt <- self$g_adapt
+
+      # Substitute pA with actual treatment probability g_treat / g_adapt
+      HA_treatment <- cf_pA_treatment * g_adapt / g_treat
+      HA_control <- cf_pA_control * (1 - g_adapt) / (1 - g_treat)
+      # HA_treatment <- cf_pA_treatment / pA
+      # HA_control <- cf_pA_control / pA
+
+      # collapse across multiple intervention nodes
+      if (!is.null(ncol(HA_treatment)) && ncol(HA_treatment) > 1) {
+        HA_treatment <- apply(HA_treatment, 1, prod)
+      }
+
+      # collapse across multiple intervention nodes
+      if (!is.null(ncol(HA_control)) && ncol(HA_control) > 1) {
+        HA_control <- apply(HA_control, 1, prod)
+      }
+
+      HA <- HA_treatment + HA_control
+
+      HA <- bound(HA, c(-40, 40))
+      return(list(Y = HA))
+    },
+    estimates = function(tmle_task = NULL, fold_number = "full") {
+      if (is.null(tmle_task)) {
+        tmle_task <- self$observed_likelihood$training_task
+      }
+
+      intervention_nodes <- union(names(self$intervention_list_treatment), names(self$intervention_list_control))
+
+      # clever_covariates happen here (for this param) only, but this is repeated computation
+      HA <- self$clever_covariates(tmle_task, fold_number)[[self$outcome_node]]
+
+
+      # todo: make sure we support updating these params
+      pA <- self$observed_likelihood$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_treatment <- self$cf_likelihood_treatment$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+      cf_pA_control <- self$cf_likelihood_control$get_likelihoods(tmle_task, intervention_nodes, fold_number)
+
+      # todo: extend for stochastic
+      cf_task_treatment <- self$cf_likelihood_treatment$enumerate_cf_tasks(tmle_task)[[1]]
+      cf_task_control <- self$cf_likelihood_control$enumerate_cf_tasks(tmle_task)[[1]]
+
+      Y <- tmle_task$get_tmle_node(self$outcome_node, impute_censoring = TRUE)
+
+      EY <- self$observed_likelihood$get_likelihood(tmle_task, self$outcome_node, fold_number)
+      EY1 <- self$observed_likelihood$get_likelihood(cf_task_treatment, self$outcome_node, fold_number)
+      EY0 <- self$observed_likelihood$get_likelihood(cf_task_control, self$outcome_node, fold_number)
+
+      psi <- mean(EY1 * self$g_adapt + EY0 * (1 - self$g_adapt))
+
+      # Need to double check
+      # IC <- HA * (Y - EY) + (EY1 * self$g_adapt + EY0 * (1 - self$g_adapt)) - psi
+      IC <- HA * (Y - EY)
+
+      result <- list(psi = psi, IC = IC)
+      return(result)
+    }
+  ),
+  active = list(
+    name = function() {
+      # param_form <- sprintf("ATE[%s_{%s}-%s_{%s}]", self$outcome_node, self$cf_likelihood_treatment$name, self$outcome_node, self$cf_likelihood_control$name)
+      param_form <- "ADSM[Y_{g_adapt}]"
+      return(param_form)
+    },
+    g_treat = function(){
+      return (private$.g_treat)
+    },
+    g_adapt = function(){
+      return (private$.g_adapt)
+    },
+    cf_likelihood_treatment = function() {
+      return(private$.cf_likelihood_treatment)
+    },
+    cf_likelihood_control = function() {
+      return(private$.cf_likelihood_control)
+    },
+    intervention_list_treatment = function() {
+      return(self$cf_likelihood_treatment$intervention_list)
+    },
+    intervention_list_control = function() {
+      return(self$cf_likelihood_control$intervention_list)
+    },
+    update_nodes = function() {
+      return(c(self$outcome_node))
+    }
+  ),
+  private = list(
+    .type = "ADSM",
+    .g_treat = NULL,
+    .g_adapt = NULL,
+    .cf_likelihood_treatment = NULL,
+    .cf_likelihood_control = NULL,
+    .supports_outcome_censoring = TRUE
+  )
+)