hi

R/Param_coxph.R

@@ -53,7 +53,6 @@ Param_coxph <- R6Class(
   inherit = Param_base,
   public = list(
     initialize = function(observed_likelihood, formula_coxph = ~1, intervention_list_treatment, intervention_list_control, family_fluctuation = c("binomial"), outcome_node = "N") {
-
       super$initialize(observed_likelihood, list(), outcome_node = outcome_node)
       family_fluctuation <- match.arg(family_fluctuation)
       training_task <- self$observed_likelihood$training_task
@@ -123,7 +122,7 @@ Param_coxph <- R6Class(
       pC_mat <- self$long_to_mat(pC, id, time)
       S_censor_mat <- self$hm_to_sm(pC_mat)
       S_censor_mat <- cbind(1, S_censor_mat[, -ncol(S_censor_mat)])
-      S_censor <-  pmax(as.vector(S_censor_mat), 0.005)# Back to long, CHECK
+      S_censor <- pmax(as.vector(S_censor_mat), 0.005) # Back to long, CHECK
       pN_mat <- self$long_to_mat(pN, id, time)
       S_surv_mat <- self$hm_to_sm(pN_mat)
       S_surv_mat <- cbind(1, S_surv_mat[, -ncol(S_surv_mat)])
@@ -136,9 +135,9 @@ Param_coxph <- R6Class(
       t_grid <- sort(unique(time))
 
 
-      H <- as.matrix(Vt * (prefailure / S_censor / S_surv) * (A / g1 * HR - (1 - A) / g0))
+      H <- as.matrix(Vt * (prefailure / S_censor) * (A / g1 * HR - (1 - A) / g0))
 
-      #print(quantile(H))
+      # print(quantile(H))
 
       EIF_N <- NULL
 
@@ -151,23 +150,20 @@ Param_coxph <- R6Class(
 
 
         scaleinv <- solve(scale)
-        EIF_N <- self$weights * (H %*% scaleinv) * as.vector(dNt - pN)
+        EIF_N <- self$weights * (H) * as.vector(dNt - pN)
         EIF_WA <- apply(Vt, 2, function(v) {
           long_vec <- self$weights * (v * (HR * pN0 - pN1))
           wide_vec <- self$long_to_mat(long_vec, id, time)
           means <- colMeans(wide_vec)
           as.vector(t(t(wide_vec) - means))
-        }) %*% scaleinv
-
-
-
+        })
       }
 
 
 
 
 
-      return(list(N = H, EIF = list(N = EIF_N, WA = EIF_WA)))
+      return(list(N = H, EIF = list(N = EIF_N, WA = EIF_WA, scaleinv = scaleinv)))
     },
     estimates = function(tmle_task = NULL, fold_number = "full") {
       if (is.null(tmle_task)) {
@@ -188,12 +184,13 @@ Param_coxph <- R6Class(
       id <- tmle_task$id
       long_order <- order(id, time)
       # clever_covariates happen here (for this param) only, but this is repeated computation
-      EIF <- self$clever_covariates(tmle_task, fold_number, is_training_task = TRUE)$EIF
+      EIFs <- self$clever_covariates(tmle_task, fold_number, is_training_task = TRUE)$EIF
+      EIF <- EIFs
       EIF <- EIF$N + EIF$WA
 
       EIF <- apply(EIF, 2, function(col) {
         rowSums(self$long_to_mat(col, id, time))
-      })
+      }) %*% EIFs$scaleinv
 
       pN <- self$observed_likelihood$get_likelihoods(tmle_task, "N", fold_number)
       pC <- self$observed_likelihood$get_likelihoods(tmle_task, "A_c", fold_number)
@@ -209,7 +206,7 @@ Param_coxph <- R6Class(
 
 
 
-      beta <- suppressWarnings(coef(glm.fit(Vt, pN1, offset = log(pN0), family = poisson(), weights =  self$weights )))
+      beta <- suppressWarnings(coef(glm.fit(Vt, pN1, offset = log(pN0), family = poisson(), weights = self$weights)))
 
 
       HR <- exp(Vt %*% beta)

R/helpers_survival.R

@@ -11,7 +11,7 @@
 #' @param ... extra arguments.
 #' @export
 #' @rdname survival_tx
-survival_tx_npsem <- function(node_list, variable_types = NULL ) {
+survival_tx_npsem <- function(node_list, variable_types = NULL) {
   # make the tmle task
 
   # define censoring (lost to followup node)
@@ -38,7 +38,7 @@ survival_tx_npsem <- function(node_list, variable_types = NULL ) {
 survival_tx_task <- function(data, node_list, variable_types = NULL, ...) {
   setDT(data)
 
-  npsem <- survival_tx_npsem(node_list, variable_types )
+  npsem <- survival_tx_npsem(node_list, variable_types)
 
   if (!is.null(node_list$id)) {
     tmle_task <- tmle3_Task$new(data, npsem = npsem, id = node_list$id, time = node_list$time, ...)

R/tmle3_Spec_coxph.R

@@ -61,7 +61,7 @@ tmle3_Spec_coxph <- R6Class(
     make_tmle_task = function(data, node_list, ...) {
       variable_types <- self$options$variable_types
       data_list <- self$transform_data(data, node_list)
-      tmle_task <- survival_tx_task(data_list$long_data, data_list$long_node_list, variable_types )
+      tmle_task <- survival_tx_task(data_list$long_data, data_list$long_node_list, variable_types)
 
       return(tmle_task)
     },

vignettes/testing.Rmd

@@ -15,7 +15,7 @@ library(sl3)
 ```{r}
 passes<-c()
  for(i in 1:200){
-   tmax <- 4
+   tmax <- 5
   print(i)
 D <- DAG.empty()
 D <- D + node("W1", distr = "runif",  min = -1, max = 1) + 
@@ -27,20 +27,21 @@ D <- set.DAG(D)
 data <- sim(D, n = 1000)
 data
 
-data_N <- data[, grep("[d][N].+", colnames(data))]
-data_C <- data[, grep("[d][C].+", colnames(data))]
+data_N <- data[, grep("[d][N].+", colnames(data)), drop = F]
+data_C <- data[, grep("[d][C].+", colnames(data)), drop = F]
 
 data_surv <-  as.data.frame(do.call(rbind, lapply(1:nrow(data), function(i) {
   rowN <- data_N[i,]
   rowC <- data_C[i,]
   t <- which(rowN==1)
   tc <- which(rowC==1)
-  if(length(tc)==0){
-    tc <- tmax
-  }
   if(length(t)==0){
     t <- tmax+2
   }
+  if(length(tc)==0){
+    tc <- tmax + 1
+  }
+
   Ttilde <- min(t,tc)
   Delta <- t <= tc
   return(matrix(c(Ttilde,Delta), nrow=1))
@@ -62,7 +63,7 @@ data$Ttilde <- data_surv$Ttilde
 
   tmle3_fit <- suppressMessages(suppressWarnings(tmle3(tmle_spec_np, data, node_list, learner_list)))
 
-
+  print(tmle3_fit$summary)
   passes <- c(passes, tmle3_fit$summary$lower <= 0.5  & tmle3_fit$summary$upper >= 0.5 )
   print(mean(passes))
 }