Tmle3sim helpers

R/LF_known.R

@@ -41,10 +41,11 @@ LF_known <- R6Class(
   class = TRUE,
   inherit = LF_base,
   public = list(
-    initialize = function(name, mean_fun = stub_known, density_fun = stub_known, ..., type = "density") {
+    initialize = function(name, mean_fun = stub_known, density_fun = stub_known, sample_fun = stub_known, ..., type = "density") {
       super$initialize(name, ..., type = type)
       private$.mean_fun <- mean_fun
       private$.density_fun <- density_fun
+      private$.sample_fun <- sample_fun
     },
     get_mean = function(tmle_task, fold_number) {
       learner_task <- tmle_task$get_regression_task(self$name, scale = FALSE)
@@ -70,6 +71,9 @@ LF_known <- R6Class(
         stop(sprintf("unsupported outcome_type: %s", outcome_type$type))
       }
       return(likelihood)
+    },
+    sample = function(tmle_task, fold_number){
+      new_task <- self$sample_fun(tmle_task)
     }
   ),
   active = list(
@@ -79,11 +83,16 @@ LF_known <- R6Class(
 
     density_fun = function() {
       return(private$.density_fun)
+    },
+
+    sample_fun = function() {
+      return(private$.sample_fun)
     }
   ),
   private = list(
     .name = NULL,
     .mean_fun = NULL,
-    .density_fun = NULL
+    .density_fun = NULL,
+    .sample_fun = NULL
   )
 )

R/tmle3_Node.R

@@ -56,13 +56,15 @@ tmle3_Node <- R6Class(
   class = TRUE,
   public = list(
     initialize = function(name, variables, parents = c(),
-                          variable_type = NULL, censoring_node = NULL, scale = FALSE) {
+                              variable_type = NULL, censoring_node = NULL, scale = FALSE,
+                              observed = TRUE) {
       private$.name <- name
       private$.variables <- variables
       private$.parents <- parents
       private$.variable_type <- variable_type
       private$.scale <- scale
       private$.censoring_node <- censoring_node
+      private$.observed <- observed
     },
     print = function() {
       node_class <- class(self)[1]
@@ -90,6 +92,9 @@ tmle3_Node <- R6Class(
     parents = function() {
       return(private$.parents)
     },
+    is_observed = function() {
+      return(private$.observed)
+    },
     scale = function() {
       return(private$.scale)
     },
@@ -106,7 +111,8 @@ tmle3_Node <- R6Class(
     .censoring_node = NULL,
     .parents = NULL,
     .variable_type = NULL,
-    .scale = NULL
+    .scale = NULL,
+    .observed = NULL
   )
 )
 

R/tmle3_Task.R

@@ -177,7 +177,6 @@ tmle3_Task <- R6Class(
 
       return(data)
     },
-    # TODO: add time_variance
     get_regression_task = function(target_node, scale = FALSE, drop_censored = FALSE, is_time_variant = FALSE) {
       npsem <- self$npsem
       target_node_object <- npsem[[target_node]]

tests/testthat/test-lf_known.R

@@ -40,6 +40,11 @@ g_dens <- function(task) {
   dens <- dnorm(task$Y, mean = mean_val)
 }
 
+g_sample <- function(task) {
+  mean_val <- g_mean(task)
+  res <- rnorm(task$Y, mean = mean_val)
+}
+
 Q_mean <- function(task) {
   W <- task$data$W
   A <- task$data$A
@@ -49,7 +54,8 @@ Q_mean <- function(task) {
 # use known likelihoods
 factor_list <- list(
   define_lf(LF_emp, "W"),
-  define_lf(LF_known, "A", mean_fun = g_mean, density_fun = g_dens),
+  define_lf(LF_known, "A", mean_fun = g_mean,
+            density_fun = g_dens, sample_fun = g_sample),
   define_lf(LF_known, "Y", mean_fun = Q_mean, type = "mean")
 )
 likelihood_def <- Likelihood$new(factor_list)
@@ -70,9 +76,8 @@ if (require("tmle3shift")) {
     likelihood_override = likelihood_def
   )
 
-  tmle_task <- tmle_spec$make_tmle_task(sim_obj$data, node_list)
-  tmle_fit <- tmle3(tmle_spec, sim_obj$data, node_list, learner_list)
-
-  psi <- tmle_fit$estimates[[1]]$psi
-  var_eif <- as.numeric(var(tmle_fit$estimates[[1]]$IC))
-}
+tmle_task <- tmle_spec$make_tmle_task(sim_obj$data, node_list)
+likelihood <- tmle_spec$make_initial_likelihood(tmle_task, learner_list)
+g_task <- tmle_task$get_regression_task("A")
+lf_g <- likelihood$factor_list[["A"]]
+g_samp <- lf_g$sample(g_task)

tests/testthat/test-survival.R

@@ -33,12 +33,18 @@ sl_A <- Lrnr_sl$new(learners = list(lrnr_mean, lrnr_glm, lrnr_gam))
 learner_list <- list(A = sl_A, N = sl_A, A_c = sl_A)
 
 var_types <- list(T_tilde = Variable_Type$new("continuous"), t = Variable_Type$new("continuous"), Delta = Variable_Type$new("binomial"))
-survival_spec <- tmle_survival(
+survival_spec1 <- tmle_survival(
   treatment_level = 1, control_level = 0,
   variable_types = var_types
 )
-tmle_task <- survival_spec$make_tmle_task(df_long, node_list)
-initial_likelihood <- survival_spec$make_initial_likelihood(tmle_task, learner_list)
+
+survival_spec0 <- tmle_survival(
+  treatment_level = 0, control_level = 0,
+  variable_types = var_types
+)
+
+tmle_task <- survival_spec1$make_tmle_task(df_long, node_list)
+initial_likelihood <- survival_spec1$make_initial_likelihood(tmle_task, learner_list)
 
 up <- tmle3_Update_survival$new(
   maxit = 3e1,
@@ -51,7 +57,8 @@ up <- tmle3_Update_survival$new(
 )
 
 targeted_likelihood <- Targeted_Likelihood$new(initial_likelihood, updater = up)
-tmle_params <- survival_spec$make_params(tmle_task, targeted_likelihood)
+tmle_params <- list(survival_spec1$make_params(tmle_task, targeted_likelihood),
+                    survival_spec0$make_params(tmle_task, targeted_likelihood))
 
 max(abs(colMeans(tmle_params[[1]]$estimates(tmle_task, "validation")$IC[, 1:10])))