tlverse / tmle3

@@ -75,7 +75,7 @@
Loading
75 75
76 76
      # todo: extend for stochastic
77 77
      cf_task <- self$cf_likelihood$enumerate_cf_tasks(tmle_task)[[1]]
78 -
      
78 +
79 79
      # cf_task <- self$cf_likelihood$cf_tasks[[1]]
80 80
81 81

@@ -48,11 +48,11 @@
Loading
48 48
49 49
# Odds Ratio odds(Y1)/odds(Y0)
50 50
f_log_or <- function(x, dx) {
51 -
  log(x[[2]]/(1-x[[2]])) - log(x[[1]]/(1-x[[1]]))
51 +
  log(x[[2]] / (1 - x[[2]])) - log(x[[1]] / (1 - x[[1]]))
52 52
}
53 53
54 54
df_log_or <- function(x, dx) {
55 -
  dx[[2]] / (x[[2]]*(1-x[[2]])) - dx[[1]] / (x[[1]]*(1-x[[1]]))
55 +
  dx[[2]] / (x[[2]] * (1 - x[[2]])) - dx[[1]] / (x[[1]] * (1 - x[[1]]))
56 56
}
57 57
58 58
or_transform <- exp

@@ -207,7 +207,7 @@
Loading
207 207
      if (drop_folds) {
208 208
        new_folds <- NULL
209 209
      } else {
210 -
        new_folds <- subset_folds(self$folds,row_index)
210 +
        new_folds <- subset_folds(self$folds, row_index)
211 211
      }
212 212
      new_task$initialize(
213 213
        self$internal_data, self$npsem,

@@ -1,5 +1,4 @@
Loading
1 -
#' Defines a TML Estimator (except for the data)
2 -
#'
1 +
#' Defines a Stratified TML Estimator (except for the data)
3 2
#'
4 3
#' @importFrom R6 R6Class
5 4
#'
@@ -17,12 +16,15 @@
Loading
17 16
    },
18 17
    make_tmle_task = function(data, node_list, ...) {
19 18
      tmle_task <- self$base_spec$make_tmle_task(data, node_list, ...)
20 -
      
19 +
21 20
      return(tmle_task)
22 21
    },
23 22
    make_initial_likelihood = function(tmle_task, learner_list = NULL) {
24 -
      initial_likelihood <- self$base_spec$make_initial_likelihood(tmle_task, learner_list)
25 -
      
23 +
      initial_likelihood <- self$base_spec$make_initial_likelihood(
24 +
        tmle_task,
25 +
        learner_list
26 +
      )
27 +
26 28
      return(initial_likelihood)
27 29
    },
28 30
    make_updater = function(...) {
@@ -30,23 +32,32 @@
Loading
30 32
      return(updater)
31 33
    },
32 34
    make_targeted_likelihood = function(likelihood, updater) {
33 -
      targeted_likelihood <- self$base_spec$make_targeted_likelihood(likelihood, updater)
34 -
      
35 +
      targeted_likelihood <- self$base_spec$make_targeted_likelihood(
36 +
        likelihood,
37 +
        updater
38 +
      )
39 +
35 40
      return(targeted_likelihood)
36 41
    },
37 42
    make_params = function(tmle_task, targeted_likelihood) {
38 43
      base_params <- self$base_spec$make_params(tmle_task, targeted_likelihood)
39 -
      strat_params <- lapply(base_params, function(base_param)
40 -
        define_param(Param_stratified, targeted_likelihood, 
41 -
                     base_param, self$strata_variable))
42 -
      
44 +
      strat_params <- lapply(base_params, function(base_param) {
45 +
        define_param(
46 +
          Param_stratified, targeted_likelihood,
47 +
          base_param, self$strata_variable
48 +
        )
49 +
      })
43 50
      tmle_params <- c(base_params, strat_params)
44 51
      return(tmle_params)
45 52
    }
46 53
  ),
47 54
  active = list(
48 -
    base_spec=function(){return(private$.base_spec)},
49 -
    strata_variable=function(){return(private$.strata_variable)}
55 +
    base_spec = function() {
56 +
      return(private$.base_spec)
57 +
    },
58 +
    strata_variable = function() {
59 +
      return(private$.strata_variable)
60 +
    }
50 61
  ),
51 62
  private = list(
52 63
    .base_spec = NULL,
@@ -54,15 +65,18 @@
Loading
54 65
  )
55 66
)
56 67
57 -
#' All Treatment Specific Means
68 +
#' Stratified version of TML estimator from other Spec classes
58 69
#'
59 70
#' O=(W,A,Y)
60 71
#' W=Covariates
61 72
#' A=Treatment (binary or categorical)
62 73
#' Y=Outcome (binary or bounded continuous)
74 +
#'
63 75
#' @importFrom sl3 make_learner Lrnr_mean
64 -
#' @param base_spec an underlying spec to stratify
65 -
#' @param stra_variable the variable(s) to use for stratification
76 +
#'
77 +
#' @param base_spec An underlying spec to stratify.
78 +
#' @param strata_variable The variable(s) to use for stratification.
79 +
#'
66 80
#' @export
67 81
tmle_stratified <- function(base_spec, strata_variable) {
68 82
  # TODO: unclear why this has to be in a factory function

@@ -1,19 +1,18 @@
Loading
1 -
reindex <- function(index,subset){
2 -
  matches <- match(index,subset)
1 +
reindex <- function(index, subset) {
2 +
  matches <- match(index, subset)
3 3
  reindexed <- matches[!is.na(matches)]
4 -
  
5 4
  return(reindexed)
6 -
  
7 5
}
8 6
9 -
subset_fold <- function(fold, subset){
10 -
  origami::make_fold(fold_index(),
11 -
                     reindex(training(),subset),
12 -
                     reindex(validation(),subset))
7 +
subset_fold <- function(fold, subset) {
8 +
  origami::make_fold(
9 +
    origami::fold_index(),
10 +
    reindex(origami::training(), subset),
11 +
    reindex(origami::validation(), subset)
12 +
  )
13 13
}
14 14
15 -
subset_folds <- function(folds, subset){
16 -
  subsetted <- lapply(folds,subset_fold, subset)
17 -
  
15 +
subset_folds <- function(folds, subset) {
16 +
  subsetted <- lapply(folds, subset_fold, subset)
18 17
  return(subsetted)
19 -
}

@@ -49,52 +49,53 @@
Loading
49 49
    initialize = function(observed_likelihood, param_base, strata_variable, ..., outcome_node = "Y") {
50 50
      super$initialize(observed_likelihood, ..., outcome_node = outcome_node)
51 51
      private$.param_base <- param_base
52 -
      private$.type = sprintf("stratified %s",param_base$type)
53 -
      private$.strata_variable=strata_variable
54 -
      
55 -
      V <- observed_likelihood$training_task$get_data(,strata_variable)
56 -
      
57 -
      strata <- V[,list(weight=observed_likelihood$training_task$nrow/.N),by=names(V)]
58 -
      set(strata,,"strata_i",factor(1:nrow(strata)))
59 -
      private$.strata = strata
52 +
      private$.type <- sprintf("stratified %s", param_base$type)
53 +
      private$.strata_variable <- strata_variable
54 +
55 +
      V <- observed_likelihood$training_task$get_data(, strata_variable)
56 +
57 +
      strata <- V[, list(weight = observed_likelihood$training_task$nrow / .N), by = names(V)]
58 +
      set(strata, , "strata_i", factor(1:nrow(strata)))
59 +
      private$.strata <- strata
60 60
    },
61 61
    clever_covariates = function(tmle_task = NULL, fold_number = "full") {
62 62
      base_covs <- self$param_base$clever_covariates(tmle_task, fold_number)
63 63
      strata_weights <- self$get_strata_weights(tmle_task)
64 -
      
65 -
      strata_covs <- lapply(base_covs,`*`,strata_weights)
64 +
65 +
      strata_covs <- lapply(base_covs, `*`, strata_weights)
66 66
      return(strata_covs)
67 67
    },
68 68
    estimates = function(tmle_task = NULL, fold_number = "full") {
69 -
      
70 69
      strata_weights <- self$get_strata_weights(tmle_task)
71 -
      strata_tasks <- apply(strata_weights,2,function(weights)tmle_task[which(weights!=0)])
70 +
      strata_tasks <- apply(strata_weights, 2, function(weights) tmle_task[which(weights != 0)])
72 71
      strata_ests <- lapply(strata_tasks, self$param_base$estimates, fold_number)
73 -
      psi <- sapply(strata_ests,`[[`,"psi")
74 -
      
72 +
      psi <- sapply(strata_ests, `[[`, "psi")
73 +
75 74
      IC <- strata_weights
76 -
      all_ICs <- unlist(lapply(strata_ests,`[[`,"IC"))
77 -
      
78 -
      IC[which(strata_weights!=0)] <- IC[which(strata_weights!=0)] * all_ICs
75 +
      all_ICs <- unlist(lapply(strata_ests, `[[`, "IC"))
76 +
77 +
      IC[which(strata_weights != 0)] <- IC[which(strata_weights != 0)] * all_ICs
79 78
      result <- list(psi = psi, IC = IC)
80 79
      return(result)
81 80
    },
82 -
    get_strata_weights = function(tmle_task){
83 -
      V <- tmle_task$get_data(,self$strata_variable)
81 +
    get_strata_weights = function(tmle_task) {
82 +
      V <- tmle_task$get_data(, self$strata_variable)
84 83
      strata <- self$strata
85 -
      combined <- merge(V,strata,by=self$strata_variable, sort=FALSE, all.x=TRUE)
86 -
      combined[,index:=.I]
87 -
      strata_weights_dt <- dcast(combined,index~strata_i,value.var='weight',fill = 0, drop=FALSE)
88 -
      strata_weights <- as.matrix(strata_weights_dt[,-1, with=FALSE])
84 +
      combined <- merge(V, strata, by = self$strata_variable, sort = FALSE, all.x = TRUE)
85 +
      combined[, index := .I]
86 +
      strata_weights_dt <- dcast(combined, index ~ strata_i, value.var = "weight", fill = 0, drop = FALSE)
87 +
      strata_weights <- as.matrix(strata_weights_dt[, -1, with = FALSE])
89 88
      return(strata_weights)
90 89
    }
91 90
  ),
92 91
  active = list(
93 92
    name = function() {
94 -
      strata_labels <- apply(self$strata[,self$strata_variable, with=FALSE],1,paste,collapse=", ")
95 -
      param_form <- sprintf("%s | V=%s",
96 -
                            self$param_base$name,
97 -
                            strata_labels)
93 +
      strata_labels <- apply(self$strata[, self$strata_variable, with = FALSE], 1, paste, collapse = ", ")
94 +
      param_form <- sprintf(
95 +
        "%s | V=%s",
96 +
        self$param_base$name,
97 +
        strata_labels
98 +
      )
98 99
      return(param_form)
99 100
    },
100 101
    param_base = function() {

@@ -170,9 +170,9 @@
Loading
170 170
            )
171 171
          })
172 172
        } else if (self$fluctuation_type == "weighted") {
173 -
          if  (self$one_dimensional) {
173 +
          if (self$one_dimensional) {
174 174
            suppressWarnings({
175 -
              submodel_fit <- glm(observed ~ - 1, submodel_data,
175 +
              submodel_fit <- glm(observed ~ -1, submodel_data,
176 176
                offset = qlogis(submodel_data$initial),
177 177
                family = binomial(),
178 178
                weights = as.numeric(H),
Files Coverage
R 79.57%
Project Totals (40 files) 79.57%
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