tlverse / tmle3
Showing 4 of 4 files from the diff.
Newly tracked file
R/survival_helpers.R created.
Newly tracked file
R/LF_fit_hazards.R created.

@@ -0,0 +1,237 @@
Loading
1 +
#' Helper Functions for Survival Analysis
2 +
#'
3 +
#' Handles the W (covariates), A (treatment/intervention), T_tilde (time-to-event),
4 +
#' Delta (censoring indicator), t_max (the maximum time to estimate) survival data structure
5 +
#'
6 +
#' @param data a \code{data.frame}, or \code{data.table} containing data for use in estimation
7 +
#' @param node_list a list of character vectors, listing the variables that comprise each node
8 +
#' @param variable_types a list of variable types, one for each node. If missing, variable types will be guessed
9 +
#' @param tmle_task a \code{\link{tmle3_Task}} as constructed via \code{survival_tx_task}
10 +
#' @param learner_list a list of sl3 learners, one for A and one for Y to be used for likelihood estimation
11 +
#' @param ... extra arguments.
12 +
#' @export
13 +
#' @rdname survival_tx
14 +
survival_tx_npsem <- function(node_list, variable_types = NULL) {
15 +
	# make the tmle task
16 +
	npsem <- list(
17 +
		# TODO: causal relation, handle t_max
18 +
		define_node("W", node_list$W, variable_type = variable_types$W),
19 +
		define_node("A", node_list$A, c("W"), variable_type = variable_types$A),
20 +
    # TODO: check
21 +
		define_node("T_tilde", node_list$T_tilde, c("A", "W"), variable_type = variable_types$T_tilde),
22 +
    define_node("dN", node_list$dN, c("A", "W"), variable_type = variable_types$dN),
23 +
    define_node("dA_c", node_list$dA_c, c("A", "W"), variable_type = variable_types$dA_c),
24 +
		define_node("Delta", node_list$Delta, variable_type = variable_types$Delta)
25 +
		)
26 +
27 +
	return(npsem)
28 +
}
29 +
30 +
#' @export
31 +
#' @rdname survival_tx
32 +
survival_tx_task <- function(data, node_list, make_npsem, variable_types = NULL, ...) {
33 +
	setDT(data)
34 +
35 +
	npsem <- make_npsem(node_list, variable_types)
36 +
37 +
	if (!is.null(node_list$id)) {
38 +
    tmle_task <- tmle3_Task$new(data, npsem = npsem, id = node_list$id, ...)
39 +
  	} else {
40 +
    	tmle_task <- tmle3_Task$new(data, npsem = npsem, ...)
41 +
  	}
42 +
43 +
  	return(tmle_task)
44 +
}
45 +
46 +
# #' @export
47 +
# #' @rdname survival_tx
48 +
# survival_tx_likelihood  <- function(tmle_task, learner_list) {
49 +
# 	# covariates
50 +
#   W_factor <- define_lf(LF_emp, "W")
51 +
52 +
#   # TODO: check if necessary
53 +
#   # treatment (bound likelihood away from 0 (and 1 if binary))
54 +
#   A_type <- tmle_task$npsem[["A"]]$variable_type
55 +
#   if (A_type$type == "continous") {
56 +
#     A_bound <- c(1 / tmle_task$nrow, Inf)
57 +
#   } else if (A_type$type %in% c("binomial", "categorical")) {
58 +
#     A_bound <- 0.025
59 +
#   } else {
60 +
#     A_bound <- NULL
61 +
#   }
62 +
63 +
#   A_factor <- define_lf(LF_fit, "A", learner = learner_list[["A"]], bound = A_bound)
64 +
65 +
#   # outcome
66 +
#   T_tilde_factor <- define_lf(LF_fit_hazard, "T_tilde", learner = learner_list[["T_tilde"]])
67 +
68 +
#   # construct and train likelihood
69 +
#   factor_list <- list(W_factor, A_factor, T_tilde_factor)
70 +
71 +
#   likelihood_def <- Likelihood$new(factor_list)
72 +
#   likelihood <- likelihood_def$train(tmle_task)
73 +
#   return(likelihood)
74 +
# }
75 +
76 +
# #' @export
77 +
# #' @rdname survival_tx
78 +
# survival_tx_base_likelihood  <- function(tmle_task, learner_list) {
79 +
#   # covariates
80 +
#   W_factor <- define_lf(LF_emp, "W")
81 +
82 +
#   # TODO: check if necessary
83 +
#   # treatment (bound likelihood away from 0 (and 1 if binary))
84 +
#   A_type <- tmle_task$npsem[["A"]]$variable_type
85 +
#   if (A_type$type == "continous") {
86 +
#     A_bound <- c(1 / tmle_task$nrow, Inf)
87 +
#   } else if (A_type$type %in% c("binomial", "categorical")) {
88 +
#     A_bound <- 0.025
89 +
#   } else {
90 +
#     A_bound <- NULL
91 +
#   }
92 +
93 +
#   A_factor <- define_lf(LF_fit, "A", learner = learner_list[["A"]], bound = A_bound)
94 +
95 +
#   # construct and train likelihood
96 +
#   factor_list <- list(W_factor, A_factor)
97 +
98 +
#   likelihood_def <- Likelihood$new(factor_list)
99 +
#   likelihood <- likelihood_def$train(tmle_task)
100 +
#   return(likelihood)
101 +
# }
102 +
103 +
# survival_tx_long_npsem <- function(node_list, variable_types = NULL) {
104 +
#   npsem <- list(
105 +
#     define_node("W", node_list$W, variable_type = variable_types$W),
106 +
#     define_node("A", node_list$A, c("W"), variable_type = variable_types$A),
107 +
#     define_node("N", node_list$N, variable_type = variable_types$N),
108 +
#     define_node("A_c", node_list$A_c, variable_type = variable_types$A_c),
109 +
#     define_node("t", node_list$t, variable_type = variable_types$t),
110 +
#     # TODO: whether keep N, A_c
111 +
#     define_node("dN", node_list$dN, c("W", "A", "t"), variable_type = variable_types$dN),
112 +
#     define_node("dA_c", node_list$dA_c, c("W", "A", "t"), variable_type = variable_types$dA_c)
113 +
#     )
114 +
115 +
#   return(npsem)
116 +
# }
117 +
118 +
# make_long_tmle_task <- function(long_data, long_node_list) {
119 +
#   # TODO: function design
120 +
#   long_tmle_task <- survival_tx_task(long_data, long_node_list, survival_tx_long_npsem)
121 +
122 +
#   return(long_tmle_task)
123 +
# }
124 +
125 +
# # TODO: speed
126 +
# make_long_data <- function(short_data, short_npsem) {
127 +
#   n <- dim(short_data)[1]
128 +
#   rs <- NULL
129 +
#   t_tilde_name <- short_npsem$T_tilde$variables
130 +
#   t_max <- max(short_data[, ..t_tilde_name])
131 +
132 +
#   # change n
133 +
#   for (i in 1:n) {
134 +
#     # TODO: check
135 +
#     t_tilde <- short_data[i, ..t_tilde_name][[1]]
136 +
#     delta_name <- short_npsem$Delta$variables
137 +
#     delta <- short_data[i, ..delta_name]
138 +
#     w_name <- short_npsem$W$variables
139 +
#     w <- short_data[i, ..w_name]
140 +
#     a_name <- short_npsem$A$variables
141 +
#     a <- short_data[i, ..a_name]
142 +
#     current_df <- data.frame("t" = 1:t_max)
143 +
#     # for (t in 1:t_tilde) {
144 +
#     #   # TODO: check
145 +
#     #   current_df[t, w_name] <- w
146 +
#     #   current_df[t, a_name] <- a
147 +
#     #   # store N(t-1)
148 +
#     #   current_df[t, "N"] <- ifelse(t_tilde <= t - 1 & delta == 1, 1, 0)
149 +
#     #   current_df[t, "A_c"] <- ifelse(t_tilde <= t - 1 & delta == 0, 1, 0)
150 +
151 +
#     #   N_prev <- current_df[t, "N"]
152 +
#     #   N_t <- ifelse(t_tilde <= t & delta == 1, 1, 0)
153 +
#     #   current_df[t, "dN"] <- ifelse(N_t == 1 & N_prev == 0, 1, 0)
154 +
155 +
#     #   A_c_prev <- current_df[t, "A_c"]
156 +
#     #   A_c_t <- ifelse(t_tilde <= t & delta == 0, 1, 0)
157 +
#     #   current_df[t, "dA_c"] <- ifelse(A_c_t == 1 & A_c_prev == 0, 1, 0)
158 +
#     # }
159 +
#     current_df[, w_name] <- rep(w, t_max)
160 +
#     current_df[, a_name] <- rep(a, t_max)
161 +
162 +
#     current_df[, "N"] <- ifelse(t_tilde <= 1:t_max - 1 & rep(delta == 1, t_max), 1, 0)
163 +
#     current_df[, "A_c"] <- ifelse(t_tilde <= 1:t_max - 1 & rep(delta == 0, t_max), 1, 0)
164 +
165 +
#     N_prev <- current_df[, "N"]
166 +
#     N_t <- ifelse(t_tilde <= 1:t_max & rep(delta == 1, t_max), 1, 0)
167 +
#     current_df[, "dN"] <- ifelse(N_t == 1 & N_prev == 0, 1, 0)
168 +
169 +
#     A_c_prev <- current_df[, "A_c"]
170 +
#     A_c_t <- ifelse(t_tilde <= 1:t_max & rep(delta == 0, t_max), 1, 0)
171 +
#     current_df[, "dA_c"] <- ifelse(A_c_t == 1 & A_c_prev == 0, 1, 0)
172 +
173 +
#     if (i == 1) {
174 +
#       rs <- current_df
175 +
#     } else {
176 +
#       rs <- rbind(rs, current_df)
177 +
#     }
178 +
#   }
179 +
#   return(rs)
180 +
# }
181 +
182 +
# make_long_node_list <- function(short_npsem) {
183 +
#   w_name <- short_npsem$W$variables
184 +
#   a_name <- short_npsem$A$variables
185 +
#   node_list <- list(W = w_name, A = a_name, N = "N", A_c = "A_c", t = "t", dN = "dN", dA_c = "dA_c")
186 +
#   return(node_list)
187 +
# }
188 +
189 +
#' @export
190 +
#' @rdname survival_tx
191 +
survival_tx_likelihood  <- function(tmle_task, learner_list) {
192 +
  # covariates
193 +
  W_factor <- define_lf(LF_emp, "W")
194 +
195 +
  # TODO: check if necessary
196 +
  # treatment (bound likelihood away from 0 (and 1 if binary))
197 +
  A_type <- tmle_task$npsem[["A"]]$variable_type
198 +
  if (A_type$type == "continous") {
199 +
    A_bound <- c(1 / tmle_task$nrow, Inf)
200 +
  } else if (A_type$type %in% c("binomial", "categorical")) {
201 +
    A_bound <- 0.025
202 +
  } else {
203 +
    A_bound <- NULL
204 +
  }
205 +
206 +
  A_factor <- define_lf(LF_fit, "A", learner = learner_list[["A"]], bound = A_bound)
207 +
208 +
  npsem <- tmle_task$npsem
209 +
  delta_name <- npsem$Delta$variables
210 +
  # TODO: check
211 +
  Delta <- tmle_task$data[[delta_name]]
212 +
  t_tilde_name <- npsem$T_tilde$variables
213 +
  T_tilde <- tmle_task$data[[t_tilde_name]]
214 +
215 +
  dN_learner <- learner_list[["dN"]]
216 +
  # TODO: check
217 +
  dN_factor <- define_lf(LF_fit_hazards, "dN", 
218 +
    learner = make_learner(Lrnr_conditional_hazards, "dN", Delta, T_tilde, dN_learner))
219 +
  dA_c_learner <- learner_list[["dA_c"]]
220 +
  dA_c_factor <- define_lf(LF_fit_hazards, "dA_c", 
221 +
    learner = make_learner(Lrnr_conditional_hazards, "dA_c", Delta, T_tilde, dA_c_learner))
222 +
223 +
  factor_list <- list(W_factor, A_factor, dN_factor, dA_c_factor)
224 +
225 +
  # TODO: check
226 +
  likelihood_def <- Likelihood_survival$new(factor_list)
227 +
  likelihood <- likelihood_def$train(tmle_task)
228 +
  return(likelihood)
229 +
}
230 +
231 +
# TODO: optimize
232 +
convert_node_name <- function(node, t_max) {
233 +
  rs <- unlist(lapply(seq(t_max), function(i) {
234 +
      paste(node, as.character(i), sep = "_")
235 +
      }))
236 +
  return(rs)
237 +
}

@@ -0,0 +1,109 @@
Loading
1 +
#' @docType class
2 +
#'
3 +
#' @importFrom R6 R6Class
4 +
#' @importFrom sl3 Lrnr_base
5 +
#' @importFrom assertthat assert_that is.count is.flag
6 +
#' @importFrom delayed bundle_delayed
7 +
#' @import data.table
8 +
#' @family Likelihood objects
9 +
#' @export
10 +
#'
11 +
#' @keywords data
12 +
#'
13 +
#' @return \code{Likelihood} object
14 +
#'
15 +
#' @format \code{\link{R6Class}} object.
16 +
#'
17 +
#' @template Likelihood_extra
18 +
#'
19 +
#' @export
20 +
Likelihood_survival <- R6Class(
21 +
  classname = "Likelihood_survival",
22 +
  portable = TRUE,
23 +
  class = TRUE,
24 +
  inherit = Likelihood,
25 +
  public = list(
26 +
    initialize = function(factor_list, cache = NULL, ...) {
27 +
      super$initialize(factor_list, cache, ...)
28 +
    },
29 +
    # TODO: get likelihoods for W, A
30 +
    get_likelihoods = function(tmle_task, nodes = NULL, fold_number = "full") {
31 +
      if (is.null(nodes)) {
32 +
        nodes <- self$nodes
33 +
      }
34 +
35 +
      # TODO: decide which nodes to get
36 +
      nodes <- nodes[1:2]
37 +
      if (length(nodes) > 1) {
38 +
        all_likelihoods <- lapply(nodes, function(node) {
39 +
          self$get_likelihood(tmle_task, node, fold_number)
40 +
        })
41 +
        likelihood_dt <- as.data.table(all_likelihoods)
42 +
        setnames(likelihood_dt, nodes)
43 +
        return(likelihood_dt)
44 +
      } else {
45 +
        return(self$get_likelihood(tmle_task, nodes[[1]], fold_number))
46 +
      }
47 +
    },
48 +
    get_hazards = function(tmle_task, nodes = NULL, fold_number = "full") {
49 +
      if (is.null(nodes)) {
50 +
        nodes <- self$nodes
51 +
      }
52 +
53 +
      # TODO: decide which nodes to get
54 +
      nodes <- nodes[3:4]
55 +
      if (length(nodes) > 1) {
56 +
        all_likelihoods <- lapply(nodes, function(node) {
57 +
          self$get_likelihood(tmle_task, node, fold_number)
58 +
        })
59 +
        likelihood_dt <- as.data.table(all_likelihoods)
60 +
61 +
        # TODO: check
62 +
        new_node_names <- unlist(lapply(nodes, convert_node_name, 
63 +
          ncol(likelihood_dt) / length(nodes)))
64 +
        setnames(likelihood_dt, new_node_names)
65 +
        return(likelihood_dt)
66 +
      } else {
67 +
        return(self$get_likelihood(tmle_task, nodes[[1]], fold_number))
68 +
      }
69 +
    },
70 +
    get_survival = function(tmle_task, nodes = NULL, fold_number = "full") {
71 +
      if (is.null(nodes)) {
72 +
        nodes <- self$nodes
73 +
      }
74 +
75 +
      # TODO: decide which nodes to get
76 +
      nodes <- nodes[3:4]
77 +
      if (length(nodes) > 1) {
78 +
        all_likelihoods <- lapply(nodes, function(node) {
79 +
          self$get_likelihood(tmle_task, node, fold_number)
80 +
        })
81 +
        # TODO: transform hazards into survival
82 +
        all_likelihoods_surv <- lapply(seq(length(all_likelihoods)), function(i) {
83 +
          t(apply(1 - all_likelihoods[[i]], 1, cumprod))
84 +
        })
85 +
        likelihood_dt <- as.data.table(all_likelihoods_surv)
86 +
87 +
        # TODO: rename
88 +
        survival_names <- c("S_N", "S_A_c")
89 +
        new_node_names <- unlist(lapply(survival_names, convert_node_name, 
90 +
          ncol(likelihood_dt) / length(survival_names)))
91 +
        setnames(likelihood_dt, new_node_names)
92 +
        return(likelihood_dt)
93 +
      } else {
94 +
        return(self$get_likelihood(tmle_task, nodes[[1]], fold_number))
95 +
      }
96 +
    }
97 +
  ),
98 +
  active = list(),
99 +
  private = list()
100 +
)
101 +
102 +
#' @param ... Passes all arguments to the constructor. See documentation for the
103 +
#'  Constructor below.
104 +
#'
105 +
#' @rdname Likelihood_survival
106 +
#'
107 +
#' @export
108 +
#
109 +
make_Likelihood_survival <- Likelihood_survival$new

@@ -0,0 +1,109 @@
Loading
1 +
#' Defines a TML Estimator (except for the data)
2 +
#'
3 +
#'
4 +
#' @importFrom R6 R6Class
5 +
#'
6 +
#' @export
7 +
#
8 +
9 +
tmle3_Spec_survival <- R6Class(
10 +
  classname = "tmle3_Spec_survival",
11 +
  portable = TRUE,
12 +
  class = TRUE,
13 +
  inherit = tmle3_Spec,
14 +
  public = list(
15 +
    initialize = function(treatment_level, control_level, ...) {
16 +
      super$initialize(
17 +
        # TODO: support multi-level treatments and etc
18 +
        treatment_level = treatment_level,
19 +
        control_level = control_level, ...
20 +
      )
21 +
    },
22 +
    make_tmle_task = function(data, node_list, ...) {
23 +
      variable_types <- self$options$variable_types
24 +
25 +
      # TODO: random initialize dN and dA_c as binomials; function design
26 +
      # data[, "dN"] <- data[[node_list$T_tilde]]
27 +
      # data[, "dA_c"] <- data[[node_list$T_tilde]]
28 +
      data[, "dN"] <- rbinom(nrow(data), 1,.5)
29 +
      data[, "dA_c"] <- rbinom(nrow(data), 1,.5)
30 +
      node_list["dN"] <- "dN"
31 +
      node_list["dA_c"] <- "dA_c"
32 +
      tmle_task <- survival_tx_task(data, node_list, survival_tx_npsem, variable_types)
33 +
34 +
      return(tmle_task)
35 +
    },
36 +
    # TODO
37 +
    # make_initial_likelihood = function(tmle_task, learner_list = NULL) {
38 +
    #   # produce trained likelihood when likelihood_def provided
39 +
40 +
    #   if (!is.null(self$options$likelihood_override)) {
41 +
    #     likelihood <- self$options$likelihood_override$train(tmle_task)
42 +
    #   } else {
43 +
    #     likelihood <- survival_tx_likelihood(tmle_task, learner_list)
44 +
    #   }
45 +
46 +
    #   return(likelihood)
47 +
    # }
48 +
49 +
    # make_long_tmle_task = function(long_data, long_node_list, ...) {
50 +
    #   variable_types <- self$options$variable_types
51 +
52 +
    #   # TODO: function design
53 +
    #   long_tmle_task <- survival_tx_task(long_data, long_node_list, survival_tx_long_npsem, variable_types)
54 +
55 +
    #   return(long_tmle_task)
56 +
    # },
57 +
58 +
    make_initial_likelihood = function(tmle_task, learner_list = NULL) {
59 +
      # produce trained likelihood when likelihood_def provided
60 +
61 +
      # TODO: check if needed
62 +
      # if (!is.null(self$options$likelihood_override)) {
63 +
      #   base_likelihood <- self$options$likelihood_override$train(tmle_task)
64 +
      # } else {
65 +
      #   # make likelihood only for W, A
66 +
      #   base_likelihood <- survival_tx_base_likelihood(tmle_task, learner_list)
67 +
      # }
68 +
69 +
      # # make likelihood only for W, A
70 +
      # base_likelihood <- survival_tx_base_likelihood(tmle_task, learner_list)
71 +
72 +
      # # generate likelihood estimates for W, A
73 +
      # base_likelihood$get_likelihoods(tmle_task)
74 +
75 +
      # # transform original data into long version
76 +
      # short_data <-tmle_task$data
77 +
      # short_npsem <- tmle_task$npsem
78 +
      # long_data <- make_long_data(short_data, short_npsem)
79 +
      # long_node_list <- make_long_node_list(short_npsem)
80 +
81 +
      # # make long tmle task
82 +
      # selected_long_data <- long_data[which(long_data["N"] == 0 & long_data["A_c"] == 0),]
83 +
      # long_tmle_task <- self$make_long_tmle_task(selected_long_data, long_node_list)
84 +
85 +
      # # make likelihood for dN and dA_c
86 +
      # likelihood <- survival_tx_hazard_likelihood(long_tmle_task, learner_list)
87 +
88 +
      # # generate likelihood estimates for dN and dA_c
89 +
      # full_tmle_task <- self$make_long_tmle_task(long_data, long_node_list)
90 +
      # # TODO: set rs[72] <- 1 - rs[72] 
91 +
      # likelihood$get_likelihoods(full_tmle_task)
92 +
93 +
      # TODO: merge likelihoods
94 +
      likelihood <- survival_tx_likelihood(tmle_task, learner_list)
95 +
      return(likelihood)
96 +
    }
97 +
  ),
98 +
  active = list(),
99 +
  private = list()
100 +
)
101 +
102 +
# TODO
103 +
#' @importFrom sl3 make_learner Lrnr_mean
104 +
#' @param treatment_level the level of A that corresponds to treatment
105 +
#' @param control_level the level of A that corresponds to a control or reference level
106 +
#' @export
107 +
tmle_survival <- function(treatment_level, control_level) {
108 +
  tmle3_Spec_survival$new(treatment_level, control_level)
109 +
}

@@ -0,0 +1,110 @@
Loading
1 +
#' Hazard Likelihood Factor Estimated from Transformed Data using sl3.
2 +
#'
3 +
#' Uses an \code{sl3} learner to estimate a likelihood factor from data.
4 +
#' Inherits from \code{\link{LF_base}}; see that page for documentation on likelihood factors in general.
5 +
#'
6 +
#' @importFrom R6 R6Class
7 +
#' @importFrom uuid UUIDgenerate
8 +
#' @importFrom methods is
9 +
#' @family Likelihood objects
10 +
#' @keywords data
11 +
#'
12 +
#' @return \code{LF_base} object
13 +
#'
14 +
#' @format \code{\link{R6Class}} object.
15 +
#'
16 +
#' @section Constructor:
17 +
#'   \code{define_lf(LF_fit, name, learner, ..., type = "density")}
18 +
#'
19 +
#'   \describe{
20 +
#'     \item{\code{name}}{character, the name of the factor. Should match a node name in the nodes specified by \code{\link{tmle3_Task}$npsem}
21 +
#'     }
22 +
#'     \item{\code{learner}}{An sl3 learner to be used to estimate the factor
23 +
#'     }
24 +
#'     \item{\code{...}}{Not currently used.
25 +
#'     }
26 +
#'     \item{\code{type}}{character, either "density", for conditional density or, "mean" for conditional mean
27 +
#'     }
28 +
#'     }
29 +
#'
30 +
#' @section Fields:
31 +
#' \describe{
32 +
#'     \item{\code{learner}}{The learner or learner fit object}
33 +
#'     }
34 +
#'
35 +
#' @export
36 +
LF_fit_hazards <- R6Class(
37 +
  classname = "LF_fit_hazards",
38 +
  portable = TRUE,
39 +
  class = TRUE,
40 +
  inherit = LF_fit,
41 +
  public = list(
42 +
    initialize = function(name, learner, ..., type = "density") {
43 +
      super$initialize(name, learner, ..., type = type)
44 +
    },
45 +
    # delayed_train = function(tmle_task) {
46 +
    #   # just return prefit learner if that's what we have
47 +
    #   # otherwise, make a delayed fit and return that
48 +
    #   if (self$learner$is_trained) {
49 +
    #     return(self$learner)
50 +
    #   }
51 +
52 +
    #   # transform original data into long version
53 +
    #   short_data <-tmle_task$data
54 +
    #   short_npsem <- tmle_task$npsem
55 +
    #   long_data <- make_long_data(short_data, short_npsem)
56 +
    #   long_node_list <- make_long_node_list(short_npsem)
57 +
58 +
    #   # make long tmle task
59 +
    #   selected_long_data <- long_data[which(long_data["N"] == 0 & long_data["A_c"] == 0),]
60 +
    #   # TODO: variable type
61 +
    #   long_tmle_task <- make_long_tmle_task(selected_long_data, long_node_list)
62 +
63 +
    #   return(super$delayed_train(long_tmle_task))
64 +
    # },
65 +
    # train = function(tmle_task, learner_fit) {
66 +
    #   # transform original data into long version
67 +
    #   short_data <-tmle_task$data
68 +
    #   short_npsem <- tmle_task$npsem
69 +
    #   long_data <- make_long_data(short_data, short_npsem)
70 +
    #   long_node_list <- make_long_node_list(short_npsem)
71 +
72 +
    #   # make long tmle task
73 +
    #   selected_long_data <- long_data[which(long_data["N"] == 0 & long_data["A_c"] == 0),]
74 +
    #   # TODO: variable type
75 +
    #   long_tmle_task <- make_long_tmle_task(selected_long_data, long_node_list)
76 +
77 +
    #   super$train(long_tmle_task, learner_fit)
78 +
    # },
79 +
    get_density = function(tmle_task, fold_number) {
80 +
      # # transform original data into long version
81 +
      # short_data <-tmle_task$data
82 +
      # short_npsem <- tmle_task$npsem
83 +
      # long_data <- make_long_data(short_data, short_npsem)
84 +
      # long_node_list <- make_long_node_list(short_npsem)
85 +
86 +
      # # generate likelihood estimates for dN and dA_c
87 +
      # full_tmle_task <- make_long_tmle_task(long_data, long_node_list)
88 +
89 +
      # return(super$get_density(full_tmle_task, fold_number))
90 +
91 +
      learner_task <- tmle_task$get_regression_task(self$name)
92 +
      learner <- self$learner
93 +
      preds <- learner$predict_fold(learner_task, fold_number)
94 +
95 +
      # TODO: check
96 +
      predmat <- matrix(preds, nrow = tmle_task$nrow, byrow = TRUE)
97 +
      likelihood <- predmat
98 +
      return(likelihood)
99 +
    }
100 +
  ),
101 +
  active = list(
102 +
    learner = function() {
103 +
      return(private$.learner)
104 +
    }
105 +
  ),
106 +
  private = list(
107 +
    .name = NULL,
108 +
    .learner = NULL
109 +
  )
110 +
)
Files Coverage
R 73.41%
Project Totals (43 files) 73.41%
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading