tlverse / tmle3

@@ -55,7 +55,7 @@
Loading
55 55
  inherit = Param_base,
56 56
  public = list(
57 57
    initialize = function(observed_likelihood, intervention_list_treatment, intervention_list_control, outcome_node = "Y") {
58 -
      super$initialize(observed_likelihood, list(), outcome_node)
58 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel =  list("A" = "logistic_switch", "Y" = "binomial_logit"))
59 59
      private$.cf_likelihood_treatment <- CF_Likelihood$new(observed_likelihood, intervention_list_treatment)
60 60
      private$.cf_likelihood_control <- CF_Likelihood$new(observed_likelihood, intervention_list_control)
61 61
    },
@@ -154,7 +154,6 @@
Loading
154 154
  private = list(
155 155
    .type = "ATT",
156 156
    .cf_likelihood_treatment = NULL,
157 -
    .cf_likelihood_control = NULL,
158 -
    .submodel = list("A" = "logistic_switch", "Y" = "binomial_logit")
157 +
    .cf_likelihood_control = NULL
159 158
  )
160 159
)

@@ -53,7 +53,7 @@
Loading
53 53
  inherit = Param_base,
54 54
  public = list(
55 55
    initialize = function(observed_likelihood, formula_coxph = ~1, intervention_list_treatment, intervention_list_control, family_fluctuation = c("binomial"), outcome_node = "N") {
56 -
      super$initialize(observed_likelihood, list(), outcome_node = outcome_node)
56 +
      super$initialize(observed_likelihood, list(), outcome_node = outcome_node, submodel =  list(N = "binomial_logit"))
57 57
      family_fluctuation <- match.arg(family_fluctuation)
58 58
      training_task <- self$observed_likelihood$training_task
59 59
      W <- training_task$get_regression_task("W", is_time_variant = TRUE)$Y
@@ -247,7 +247,6 @@
Loading
247 247
    .cf_likelihood_control = NULL,
248 248
    .supports_outcome_censoring = TRUE,
249 249
    .formula_coxph = NULL,
250 -
    .submodel = list(N = "binomial_logit"),
251 250
    .formula_names = NULL
252 251
  )
253 252
)

@@ -51,7 +51,7 @@
Loading
51 51
      } else {
52 52
        private$.targeted <- times %in% target_times
53 53
      }
54 -
      super$initialize(observed_likelihood, ..., outcome_node = outcome_node)
54 +
      super$initialize(observed_likelihood, ..., outcome_node = outcome_node, submodel =  list(N = "binomial_logit"))
55 55
    },
56 56
    long_to_mat = function(x, id, time) {
57 57
      dt <- data.table(id = id, time = time, x = as.vector(x))

@@ -50,7 +50,7 @@
Loading
50 50
  inherit = Param_base,
51 51
  public = list(
52 52
    initialize = function(observed_likelihood, formula_logOR = ~1, intervention_list_treatment, intervention_list_control, outcome_node = "Y") {
53 -
      super$initialize(observed_likelihood, list(), outcome_node)
53 +
      super$initialize(observed_likelihood, list(), outcome_node,  submodel = list(Y = "binomial_logit"))
54 54
      training_task <- self$observed_likelihood$training_task
55 55
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
56 56
      V <- model.matrix(formula_logOR, as.data.frame(W))
@@ -182,7 +182,6 @@
Loading
182 182
    .cf_likelihood_control = NULL,
183 183
    .supports_outcome_censoring = TRUE,
184 184
    .formula_logOR = NULL,
185 -
    .submodel = list(Y = "binomial_logit"),
186 185
    .formula_names = NULL
187 186
  )
188 187
)

@@ -52,16 +52,16 @@
Loading
52 52
  class = TRUE,
53 53
  inherit = Param_base,
54 54
  public = list(
55 -
    initialize = function(observed_likelihood, formula_CATE = ~1, intervention_list_treatment, intervention_list_control, family_fluctuation = c("binomial", "gaussian", "poisson"), outcome_node = "Y") {
56 -
      super$initialize(observed_likelihood, list(), outcome_node)
55 +
    initialize = function(observed_likelihood, formula_CATE = ~1, intervention_list_treatment, intervention_list_control, submodel = c("binomial", "gaussian", "poisson"), outcome_node = "Y") {
56 +
      submodel <- match.arg(submodel)
57 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel = submodel)
57 58
      training_task <- self$observed_likelihood$training_task
58 59
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
59 60
      V <- model.matrix(formula_CATE, as.data.frame(W))
60 61
      private$.formula_names <- colnames(V)
61 62
      private$.targeted <- rep(T, ncol(V))
62 63
63 -
      family_fluctuation <- match.arg(family_fluctuation)
64 -
      private$.submodel <- list(Y = family_fluctuation)
64 +
65 65
66 66
      if (!is.null(observed_likelihood$censoring_nodes[[outcome_node]])) {
67 67
        # add delta_Y=0 to intervention lists
@@ -198,7 +198,6 @@
Loading
198 198
    .cf_likelihood_control = NULL,
199 199
    .supports_outcome_censoring = TRUE,
200 200
    .formula_CATE = NULL,
201 -
    .submodel = list(Y = "gaussian_identity"),
202 201
    .formula_names = NULL
203 202
  )
204 203
)

@@ -51,7 +51,7 @@
Loading
51 51
  inherit = Param_base,
52 52
  public = list(
53 53
    initialize = function(observed_likelihood, formula_logRR = ~1, intervention_list_treatment, intervention_list_control, outcome_node = "Y") {
54 -
      super$initialize(observed_likelihood, list(), outcome_node)
54 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel = list(Y = "poisson_log"))
55 55
      training_task <- self$observed_likelihood$training_task
56 56
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
57 57
      V <- model.matrix(formula_logRR, as.data.frame(W))
@@ -187,7 +187,6 @@
Loading
187 187
    .cf_likelihood_control = NULL,
188 188
    .supports_outcome_censoring = TRUE,
189 189
    .formula_logRR = NULL,
190 -
    .submodel = list(Y = "poisson_log"),
191 190
    .formula_names = NULL
192 191
  )
193 192
)

@@ -117,6 +117,7 @@
Loading
117 117
118 118
      # USE first parameter to get submodel spec
119 119
      submodel_spec <- self$tmle_params[[1]]$get_submodel_spec(update_node)
120 +
120 121
      submodel_name <- submodel_spec$name
121 122
      # Check compatibility of tmle_params with submodel
122 123
      lapply(self$tmle_params, function(tmle_param) {
@@ -210,9 +211,9 @@
Loading
210 211
      submodel_data$submodel_spec <- submodel_spec
211 212
      # To support arbitrary likelihood-dependent risk functions for updating.
212 213
      # Is carrying this stuff around a problem computationally?
213 -
      submodel_data$tmle_task <- tmle_task
214 -
      submodel_data$likelihood <- likelihood
215 -
      submodel_data$fold_number <- fold_number
214 +
      # submodel_data$tmle_task <- tmle_task
215 +
      # submodel_data$likelihood <- likelihood
216 +
      # submodel_data$fold_number <- fold_number
216 217
217 218
      return(submodel_data)
218 219
    },
@@ -232,9 +233,7 @@
Loading
232 233
      family_object <- submodel_spec$family
233 234
      loss_function <- submodel_spec$loss_function
234 235
      submodel <- submodel_spec$submodel_function
235 -
      training_likelihood <- submodel_data$likelihood
236 -
      training_task <- submodel_data$tmle_task
237 -
      training_fold <- submodel_data$fold_number
236 +
238 237
      # Subset to only numericals needed for fitting.
239 238
      submodel_data <- submodel_data[c("observed", "H", "initial", "weights")]
240 239
@@ -247,11 +246,12 @@
Loading
247 246
          )
248 247
        }
249 248
249 +
        weights <- submodel_data$weights
250 250
251 251
        risk <- function(epsilon) {
252 252
          submodel_estimate <- self$apply_submodel(submodel, submodel_data, epsilon)
253 -
          loss <- loss_function(submodel_estimate, submodel_data$observed, weights = submodel_data$weights, likelihood = training_likelihood, tmle_task = training_task, fold_number = training_fold)
254 -
          mean(loss)
253 +
          loss <- loss_function(submodel_estimate, submodel_data$observed)
254 +
          weighted.mean(loss, weights)
255 255
        }
256 256
257 257

@@ -11,12 +11,12 @@
Loading
11 11
  portable = TRUE,
12 12
  class = TRUE,
13 13
  public = list(
14 -
    initialize = function(formula, estimand = c("CATE", "CATT", "TSM", "OR", "RR"), treatment_level = 1, control_level = 0, family_fluctuation = NULL,
14 +
    initialize = function(formula, estimand = c("CATE", "CATT", "TSM", "OR", "RR"), treatment_level = 1, control_level = 0, submodel = NULL,
15 15
                          likelihood_override = NULL,
16 16
                          variable_types = NULL, delta_epsilon = 0.025, ...) {
17 17
      estimand <- match.arg(estimand)
18 18
      private$.options <- list(
19 -
        estimand = estimand, formula = formula, family_fluctuation = family_fluctuation,
19 +
        estimand = estimand, formula = formula, submodel = submodel,
20 20
        treatment_level = treatment_level, control_level = control_level, delta_epsilon = delta_epsilon,
21 21
        likelihood_override = likelihood_override,
22 22
        variable_types = variable_types, ...
@@ -27,7 +27,7 @@
Loading
27 27
      include_variance_node <- FALSE
28 28
      scale_outcome <- TRUE
29 29
      Y <- data[[node_list$Y]]
30 -
      family <- self$options$family_fluctuation
30 +
      family <- self$options$submodel
31 31
32 32
      if (is.null(family) && self$options$estimand %in% c("CATE", "CATT", "TSM")) {
33 33
        if (all(Y %in% c(0, 1))) {
@@ -54,7 +54,7 @@
Loading
54 54
          scale_outcome <- FALSE
55 55
        }
56 56
      }
57 -
      private$.options$family_fluctuation <- family
57 +
      private$.options$submodel <- family
58 58
      binary_outcome <- all(data[[node_list$Y]] %in% c(0, 1))
59 59
      private$.options$binary_outcome <- binary_outcome
60 60
      if (self$options$estimand == "RR") {
@@ -95,7 +95,7 @@
Loading
95 95
      } else if (self$options$estimand == "OR") {
96 96
        updater <- tmle3_Update$new(maxit = 200, one_dimensional = TRUE, convergence_type = convergence_type, verbose = verbose, delta_epsilon = delta_epsilon, constrain_step = TRUE, bounds = 0.0025, ...)
97 97
      } else if (self$options$estimand == "RR") {
98 -
        if (self$options$family_fluctuation == "poisson") {
98 +
        if (self$options$submodel == "poisson") {
99 99
          bounds <- list(Y = c(0.0025, Inf), A = 0.005)
100 100
        } else {
101 101
          bounds <- list(Y = 0.0025, A = 0.005)
@@ -114,7 +114,7 @@
Loading
114 114
      treatment_value <- self$options$treatment_level
115 115
      control_value <- self$options$control_level
116 116
      formula <- self$options$formula
117 -
      family <- self$options$family_fluctuation
117 +
      family <- self$options$submodel
118 118
      A_levels <- tmle_task$npsem[["A"]]$variable_type$levels
119 119
      if (!is.null(A_levels)) {
120 120
        treatment_value <- factor(treatment_value, levels = A_levels)
@@ -127,7 +127,7 @@
Loading
127 127
        # If TSM generate params for all levels
128 128
        param <- lapply(union(treatment_value, control_value), function(value) {
129 129
          treatment <- define_lf(LF_static, "A", value = value)
130 -
          return(Param_npTSM$new(targeted_likelihood, formula, treatment, family_fluctuation = family))
130 +
          return(Param_npTSM$new(targeted_likelihood, formula, treatment, submodel = family))
131 131
        })
132 132
        return(param)
133 133
      } else {
@@ -136,13 +136,13 @@
Loading
136 136
      }
137 137
138 138
      if (self$options$estimand == "CATE") {
139 -
        param <- Param_npCATE$new(targeted_likelihood, formula, treatment, control, family_fluctuation = family)
139 +
        param <- Param_npCATE$new(targeted_likelihood, formula, treatment, control, submodel = family)
140 140
      } else if (self$options$estimand == "CATT") {
141 -
        param <- Param_npCATT$new(targeted_likelihood, formula, treatment, control, family_fluctuation = family)
141 +
        param <- Param_npCATT$new(targeted_likelihood, formula, treatment, control, submodel = family)
142 142
      } else if (self$options$estimand == "OR") {
143 143
        param <- Param_npOR$new(targeted_likelihood, formula, treatment, control)
144 144
      } else if (self$options$estimand == "RR") {
145 -
        param <- Param_npRR$new(targeted_likelihood, formula, treatment, control, binary_outcome = self$options$binary_outcome, family_fluctuation = family)
145 +
        param <- Param_npRR$new(targeted_likelihood, formula, treatment, control, binary_outcome = self$options$binary_outcome, submodel = family)
146 146
      }
147 147
      return(list(param))
148 148
    }

@@ -201,7 +201,6 @@
Loading
201 201
    .cf_likelihood_control = NULL,
202 202
    .supports_outcome_censoring = TRUE,
203 203
    .formula_logOR = NULL,
204 -
    .submodel = list(Y = "binomial_logit"),
205 204
    .formula_names = NULL
206 205
  )
207 206
)

@@ -50,7 +50,7 @@
Loading
50 50
  inherit = Param_base,
51 51
  public = list(
52 52
    initialize = function(observed_likelihood, formula_CATE = ~1, intervention_list_treatment, intervention_list_control, outcome_node = "Y") {
53 -
      super$initialize(observed_likelihood, list(), outcome_node)
53 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel = list(Y = "gaussian_identity"))
54 54
      training_task <- self$observed_likelihood$training_task
55 55
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
56 56
      V <- model.matrix(formula_CATE, as.data.frame(W))
@@ -200,7 +200,6 @@
Loading
200 200
    .cf_likelihood_control = NULL,
201 201
    .supports_outcome_censoring = TRUE,
202 202
    .formula_CATE = NULL,
203 -
    .submodel = list(Y = "gaussian_identity"),
204 203
    .formula_names = NULL
205 204
  )
206 205
)

@@ -61,6 +61,7 @@
Loading
61 61
      private$.cf_likelihood_control <- CF_Likelihood$new(observed_likelihood, intervention_list_control)
62 62
      private$.outcome_node <- outcome_node
63 63
      private$.param_att <- Param_ATT$new(observed_likelihood, intervention_list_control, intervention_list_treatment, outcome_node)
64 +
      private$.submodel <- private$.param_att$submodel
64 65
    },
65 66
    clever_covariates = function(tmle_task = NULL, fold_number = "full") {
66 67
      att_cc <- self$param_att$clever_covariates(tmle_task, fold_number)
@@ -96,6 +97,9 @@
Loading
96 97
    },
97 98
    param_att = function() {
98 99
      return(private$.param_att)
100 +
    },
101 +
    submodel = function(){
102 +
      self$param_att$submodel
99 103
    }
100 104
  ),
101 105
  private = list(
@@ -103,7 +107,6 @@
Loading
103 107
    .param_att = NULL,
104 108
    .outcome_node = NULL,
105 109
    .cf_likelihood_treatment = NULL,
106 -
    .cf_likelihood_control = NULL,
107 -
    .submodel = list("A" = "logistic_switch", "Y" = "binomial_logit")
110 +
    .cf_likelihood_control = NULL
108 111
  )
109 112
)

@@ -52,10 +52,9 @@
Loading
52 52
  class = TRUE,
53 53
  inherit = Param_base,
54 54
  public = list(
55 -
    initialize = function(observed_likelihood, formula_TSM = ~1, intervention_list, family_fluctuation = c("binomial", "gaussian", "poisson"), outcome_node = "Y") {
56 -
      family_fluctuation <- match.arg(family_fluctuation)
57 -
      private$.submodel <- list(Y = family_fluctuation)
58 -
      super$initialize(observed_likelihood, list(), outcome_node)
55 +
    initialize = function(observed_likelihood, formula_TSM = ~1, intervention_list, submodel = c("binomial", "gaussian", "poisson"), outcome_node = "Y") {
56 +
      submodel <- match.arg(submodel)
57 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel = submodel)
59 58
      training_task <- self$observed_likelihood$training_task
60 59
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
61 60
      V <- model.matrix(formula_TSM, as.data.frame(W))
@@ -174,7 +173,6 @@
Loading
174 173
    .cf_likelihood = NULL,
175 174
    .supports_outcome_censoring = TRUE,
176 175
    .formula_TSM = NULL,
177 -
    .submodel = list(Y = "binomial_identity"),
178 176
    .formula_names = NULL
179 177
  )
180 178
)

@@ -20,9 +20,23 @@
Loading
20 20
  portable = TRUE,
21 21
  class = TRUE,
22 22
  public = list(
23 -
    initialize = function(observed_likelihood, ..., outcome_node = "Y") {
23 +
    initialize = function(observed_likelihood, ...,  outcome_node = "Y", submodel = NULL) {
24 24
      private$.observed_likelihood <- observed_likelihood
25 25
      private$.outcome_node <- outcome_node
26 +
      if(is.null(submodel)) { # Default submodel
27 +
        submodel <- list("A" = get_submodel_spec("binomial_logit"), "Y" = get_submodel_spec("binomial_logit"), "default" = get_submodel_spec("binomial_logit"))
28 +
      } else if (is.list(submodel)) { # Convert to submodel spec list
29 +
        submodel_names <- names(submodel)
30 +
31 +
        submodel <- lapply(submodel, get_submodel_spec) # For each node, convert to submodel spec list. #get_submodel_spec does nothing if item is already a list
32 +
        names(submodel) <- submodel_names
33 +
      } else {
34 +
        submodel <- list("default" = get_submodel_spec(submodel))
35 +
      }
36 +
37 +
38 +
      private$.submodel <- submodel
39 +
26 40
27 41
      if (!is.null(observed_likelihood$censoring_nodes[[outcome_node]])) {
28 42
        if (!self$supports_outcome_censoring) {
@@ -55,13 +69,22 @@
Loading
55 69
      if (!(node %in% names(private$.submodel))) {
56 70
        node <- "default"
57 71
      }
58 -
      return(submodel_name %in% c(private$.submodel[[node]]))
72 +
      return(submodel_name == private$.submodel[[node]]$name)
59 73
    },
60 74
    get_submodel_spec = function(update_node) {
61 -
      if (!(update_node %in% names(private$.submodel))) {
75 +
76 +
      if (!(update_node %in% names(self$submodel))) {
62 77
        update_node <- "default"
63 78
      }
64 -
      return(get_submodel_spec(private$.submodel[[update_node]]))
79 +
80 +
      spec <- self$submodel[[update_node]]
81 +
      if(!is.list(spec)) {
82 +
83 +
        spec <- get_submodel_spec(spec)
84 +
        private$.submodel[[update_node]] <- spec
85 +
      }
86 +
87 +
      return(spec)
65 88
    }
66 89
  ),
67 90
  active = list(
@@ -97,7 +120,7 @@
Loading
97 120
    .outcome_node = NULL,
98 121
    .targeted = TRUE,
99 122
    .supports_outcome_censoring = FALSE,
100 -
    .submodel = list("A" = "binomial_logit", "Y" = "binomial_logit", "default" = "binomial_logit")
123 +
    .submodel = NULL
101 124
  )
102 125
)
103 126

@@ -49,16 +49,15 @@
Loading
49 49
  class = TRUE,
50 50
  inherit = Param_base,
51 51
  public = list(
52 -
    initialize = function(observed_likelihood, formula_CATT = ~1, intervention_list_treatment, intervention_list_control, family_fluctuation = c("binomial", "gaussian", "poisson"), outcome_node = "Y") {
53 -
      super$initialize(observed_likelihood, list(), outcome_node)
52 +
    initialize = function(observed_likelihood, formula_CATT = ~1, intervention_list_treatment, intervention_list_control, submodel = c("binomial", "gaussian", "poisson"), outcome_node = "Y") {
53 +
      submodel <- match.arg(submodel)
54 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel = submodel)
54 55
      training_task <- self$observed_likelihood$training_task
55 56
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
56 57
      V <- model.matrix(formula_CATT, as.data.frame(W))
57 58
      private$.formula_names <- colnames(V)
58 59
      private$.targeted <- rep(T, ncol(V))
59 60
60 -
      family_fluctuation <- match.arg(family_fluctuation)
61 -
      private$.submodel <- list(Y = family_fluctuation)
62 61
63 62
      if (!is.null(observed_likelihood$censoring_nodes[[outcome_node]])) {
64 63
        # add delta_Y=0 to intervention lists
@@ -200,7 +199,6 @@
Loading
200 199
    .cf_likelihood_control = NULL,
201 200
    .supports_outcome_censoring = TRUE,
202 201
    .formula_CATT = NULL,
203 -
    .submodel = list(Y = "gaussian_identity"),
204 202
    .formula_names = NULL
205 203
  )
206 204
)

@@ -52,16 +52,16 @@
Loading
52 52
  class = TRUE,
53 53
  inherit = Param_base,
54 54
  public = list(
55 -
    initialize = function(observed_likelihood, formula_RR = ~1, intervention_list_treatment, intervention_list_control, binary_outcome = FALSE, family_fluctuation = c("poisson", "binomial"), outcome_node = "Y") {
56 -
      super$initialize(observed_likelihood, list(), outcome_node)
57 -
      family_fluctuation <- match.arg(family_fluctuation)
55 +
    initialize = function(observed_likelihood, formula_RR = ~1, intervention_list_treatment, intervention_list_control, binary_outcome = FALSE, submodel = c("poisson", "binomial"), outcome_node = "Y") {
56 +
      submodel <- match.arg(submodel)
57 +
      super$initialize(observed_likelihood, list(), outcome_node, submodel = submodel)
58 58
      training_task <- self$observed_likelihood$training_task
59 59
      W <- training_task <- self$observed_likelihood$training_task$get_tmle_node("W")
60 60
      V <- model.matrix(formula_RR, as.data.frame(W))
61 61
      private$.formula_names <- colnames(V)
62 62
      private$.targeted <- rep(T, ncol(V))
63 63
      private$.binary_outcome <- binary_outcome
64 -
      private$.submodel <- list(Y = family_fluctuation)
64 +
65 65
66 66
67 67
      if (!is.null(observed_likelihood$censoring_nodes[[outcome_node]])) {
@@ -192,7 +192,6 @@
Loading
192 192
    .cf_likelihood_control = NULL,
193 193
    .supports_outcome_censoring = TRUE,
194 194
    .formula_RR = NULL,
195 -
    .submodel = list(Y = "binomial_logit"),
196 195
    .formula_names = NULL,
197 196
    .binary_outcome = NULL
198 197
  )

@@ -1,9 +1,50 @@
Loading
1 +
2 +
# To port to sl3 at some point:
3 +
4 +
#' Log likelihood loss for outcomes between 0 and 1
5 +
#'
6 +
#' @param estimate prediction
7 +
#' @param observed observed outcome
8 +
#' @export
9 +
loss_loglik_binomial <- function(estimate, observed) {
10 +
  # loss <- -1 * ifelse(observed == 1, log(estimate), log(1 - estimate))
11 +
  loss <- -1 * (observed * log(estimate) + (1 - observed) * log(1 - estimate))
12 +
  return(loss)
13 +
}
14 +
#' log likelihood loss
15 +
#' @param estimate prediction
16 +
#' @param observed observed outcome
17 +
#' @export
18 +
loss_loglik <- function(estimate, observed) {
19 +
  loss <- -1 * log(estimate)
20 +
  return(loss)
21 +
}
22 +
23 +
#' Poisson/log-linear loss for nonnegative variables
24 +
#'
25 +
#' @param estimate prediction
26 +
#' @param observed observed outcome
27 +
#' @export
28 +
loss_poisson <- function(estimate, observed ) {
29 +
  loss <- estimate - observed * log(estimate)
30 +
  return(loss)
31 +
}
32 +
33 +
34 +
35 +
36 +
37 +
38 +
39 +
1 40
#' Generate Fluctuation Submodel from \code{family} object.
2 41
#'
3 42
#' @param family ...
4 43
#'
5 44
#' @export
6 45
#
46 +
47 +
7 48
generate_submodel_from_family <- function(family) {
8 49
  linkfun <- family$linkfun
9 50
  linkinv <- family$linkinv
@@ -30,82 +71,8 @@
Loading
30 71
  output <- ifelse(observed == 1, output, 1 - output)
31 72
}
32 73
33 -
#' Log likelihood loss for binary variables
34 -
#'
35 -
#' @param estimate ...
36 -
#' @param observed ...
37 -
#' @param weights ...
38 -
#' @param v ...
39 -
#' @export
40 -
loss_function_loglik_binomial <- function(estimate, observed, weights = NULL, likelihood = NULL, tmle_task = NULL, fold_number = NULL) {
41 -
  # loss <- -1 * ifelse(observed == 1, log(estimate), log(1 - estimate))
42 -
  loss <- -1 * (observed * log(estimate) + (1 - observed) * log(1 - estimate))
43 -
  if (!is.null(weights)) {
44 -
    loss <- weights * loss
45 -
  }
46 -
  return(loss)
47 -
}
48 -
#' @export
49 -
loss_function_loglik <- function(estimate, observed, weights = NULL, likelihood = NULL, tmle_task = NULL, fold_number = NULL) {
50 -
  loss <- -1 * log(estimate)
51 -
  if (!is.null(weights)) {
52 -
    loss <- weights * loss
53 -
  }
54 -
  return(loss)
55 -
}
56 -
57 -
#' Linear (gaussian) Submodel Fluctuation
58 -
#'
59 -
#' @param eps ...
60 -
#' @param X ...
61 -
#' @param offset ...
62 -
#'
63 -
#'
64 -
#' @export
65 -
#
66 -
submodel_linear <- generate_submodel_from_family(gaussian())
67 -
#' Least-squares loss for binary variables
68 -
#'
69 -
#' @param estimate ...
70 -
#' @param observed ...
71 -
#' @param weights ...
72 -
#' @param likelihood ...
73 -
#' @export
74 -
loss_function_least_squares <- function(estimate, observed, weights = NULL, likelihood = NULL, tmle_task = NULL, fold_number = NULL) {
75 -
  loss <- (observed - estimate)^2
76 -
  if (!is.null(weights)) {
77 -
    loss <- weights * loss
78 -
  }
79 -
  return(loss)
80 -
}
81 74
82 75
83 -
#' Log-linear (Poisson) Submodel Fluctuation
84 -
#'
85 -
#' @param eps ...
86 -
#' @param X ...
87 -
#' @param offset ...
88 -
#'
89 -
#'
90 -
#' @export
91 -
#
92 -
submodel_exp <- generate_submodel_from_family(poisson())
93 -
94 -
#' Poisson/log-linear loss for nonnegative variables
95 -
#'
96 -
#' @param estimate ...
97 -
#' @param observed ...
98 -
#' @param weights ...
99 -
#' @param likelihood ...
100 -
#' @export
101 -
loss_function_poisson <- function(estimate, observed, weights = NULL, likelihood = NULL, tmle_task = NULL, fold_number = NULL) {
102 -
  loss <- estimate - observed * log(estimate)
103 -
  if (!is.null(weights)) {
104 -
    loss <- weights * loss
105 -
  }
106 -
  return(loss)
107 -
}
108 -
109 76
#' Generate loss function loss from family object or string
110 77
#' @param family ...
111 78
#' @export
@@ -117,11 +84,11 @@
Loading
117 84
    stop("Unsupported family object.")
118 85
  }
119 86
  if (family == "poisson") {
120 -
    return(loss_function_poisson)
87 +
    return(loss_poisson)
121 88
  } else if (family == "gaussian") {
122 -
    return(loss_function_least_squares)
89 +
    return(loss_squared_error)
123 90
  } else if (family == "binomial") {
124 -
    return(loss_function_loglik_binomial)
91 +
    return(loss_loglik_binomial)
125 92
  }
126 93
}
127 94
@@ -147,6 +114,11 @@
Loading
147 114
#' @param name Either a name for a submodel spec obtainable from environment (name -->  get(paste0("submodel_spec_",name))}), a family object or string, or a string of the form "family_link" (e.g. "binomial_logit").
148 115
#' @export
149 116
get_submodel_spec <- function(name) {
117 +
  # If list, assume it is already a spec
118 +
119 +
  if(is.list(name)){
120 +
    return(name)
121 +
  }
150 122
  output <- NULL
151 123
  tryCatch(
152 124
    {
@@ -163,6 +135,7 @@
Loading
163 135
      output <- make_submodel_spec(name, family)
164 136
    },
165 137
    error = function(...) {
138 +
      print(...)
166 139
      try({
167 140
        output <<- get(paste0("submodel_spec_", name))
168 141
      })
@@ -178,4 +151,4 @@
Loading
178 151
#' @export
179 152
submodel_spec_logistic_switch <- list(name = "logistic_switch", family = function() {
180 153
  stop("Does not support family-based updating. Please use optim instead.")
181 -
}, submodel_function = submodel_logistic_switch, loss_function = loss_function_loglik)
154 +
}, submodel_function = submodel_logistic_switch, loss_function = loss_loglik)
Files Coverage
R 74.19%
Project Totals (63 files) 74.19%
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