allowing f_gstar1/f_gstar2 to be a vector of length n or a constant (…

…e.g., 1 or 0)

R/DatNet_class.R

@@ -55,29 +55,36 @@ is.integerish <- function (x) is.integer(x) || (is.numeric(x) && all(x == as.int
 #' @importFrom stats as.formula glm na.exclude rbinom 
 NULL
 
-# # Get the prob P(A^*=1|W) (under known stoch. intervention f_gstar) from user-supplied function, fcn_name_prob:
-# # NOT USED
-# f.gen.probA.star <- function(data, fcn_name_prob) {
-#   .f_g_wrapper <- function(data, fcn_name_prob, ...) {
-#       args0 <- list(k = k, data = data)
-#       args <- c(args0, ...)
-#     do.call(fcn_name_prob, args)
-#   }
-#   probA <- .f_g_wrapper(data = data, fcn_name_prob = fcn_name_prob)
-#   return(probA)
-# }
 # Get the actual A^* sampled from user-supplied intervention f_gstar (fcn_name):
-f.gen.A.star <- function(data, fcn_name) {
-  .f_g_wrapper <- function(data, fcn_name, ...) {
+f.gen.A.star <- function(data, f.g_fun) {
+  .f_g_wrapper <- function(data, f.g_fun, ...) {
       args0 <- list(data = data)
       args <- c(args0, ...)
-    do.call(fcn_name, args)
+    do.call(f.g_fun, args)
+  }
+  # test f.g_fun is a function, if not it must be a vector
+  if (!is.function(f.g_fun)) {
+    newA <- as.vector(f.g_fun)
+    if (length(newA)!=nrow(data) && length(newA)!=1L) stop("f_gstar1/f_gstar2 must be either a function or a vector of length nrow(data) or 1")
+    if (length(newA)==1L) newA <- rep_len(newA, nrow(data))
+  } else {
+    if (!("data" %in% names(formals(f.g_fun)))) stop("functions f_gstar1 / f_gstar2 must have a named argument 'data'")  
+    newA <- .f_g_wrapper(data = data, f.g_fun = f.g_fun)
   }
-  if (!("data" %in% names(formals(fcn_name)))) stop("functions f_gstar1 / f_gstar2 must have a named argument 'data'")
-  # if (missing(data)) stop("function f_gstar1 or f_gstar2 does not accept argument")
-  newA <- .f_g_wrapper(data = data, fcn_name = fcn_name)
   return(newA)
 }
+# # Get the prob P(A^*=1|W) (under known stoch. intervention f_gstar) from user-supplied function, f.g_fun_prob:
+# # NOT USED
+# f.gen.probA.star <- function(data, f.g_fun_prob) {
+#   .f_g_wrapper <- function(data, f.g_fun_prob, ...) {
+#       args0 <- list(k = k, data = data)
+#       args <- c(args0, ...)
+#     do.call(f.g_fun_prob, args)
+#   }
+#   probA <- .f_g_wrapper(data = data, f.g_fun_prob = f.g_fun_prob)
+#   return(probA)
+# }
+
 
 ## ---------------------------------------------------------------------
 # DETECTING VECTOR TYPES
@@ -440,7 +447,7 @@ DatNet <- R6Class(classname = "DatNet",
 #'   \item{\code{binirize.cat.sVar(name.sVar, levels)}}{...}
 #'   \item{\code{get.sVar.bw(name.sVar, intervals)}}{...}
 #'   \item{\code{get.sVar.bwdiff(name.sVar, intervals)}}{...}
-#'   \item{\code{make.dat.sWsA(p = 1, f.g_name = NULL, sA.object = NULL)}}{...}
+#'   \item{\code{make.dat.sWsA(p = 1, f.g_fun = NULL, sA.object = NULL)}}{...}
 #' }
 #' @section Active Bindings:
 #' \describe{
@@ -628,35 +635,35 @@ DatNet.sWsA <- R6Class(classname = "DatNet.sWsA",
     },
 
     # This function returns mat.sVar, which is a matrix that combines all sW and sA summary measures;
-    # Odata is only needed for evaluating new sA (!is.null(f.g_name));
-    # When !is.null(f.g_name) create p new datnetA.gstar's (n obs at a time), which are not saved separately (only combined);
-    # When is.null(f.g_name), returns combined cbind(sW, sA) for observed O.datnetW, O.datnetA;
+    # Odata is only needed for evaluating new sA (!is.null(f.g_fun));
+    # When !is.null(f.g_fun) create p new datnetA.gstar's (n obs at a time), which are not saved separately (only combined);
+    # When is.null(f.g_fun), returns combined cbind(sW, sA) for observed O.datnetW, O.datnetA;
     # TO ADD: Consider passing ahead a total number of sA that will be created by DatNet class (need it to pre-allocate self$dat.sWsA);
-    make.dat.sWsA = function(p = 1, f.g_name = NULL, sA.object = NULL)  {
-    # make.dat.sWsA = function(p = 1, f.g_name = NULL, f.g_args = NULL, sA.object = NULL)  {
+    make.dat.sWsA = function(p = 1, f.g_fun = NULL, sA.object = NULL)  {
+    # make.dat.sWsA = function(p = 1, f.g_fun = NULL, f.g_args = NULL, sA.object = NULL)  {
       datnetW <- self$datnetW
       datnetA <- self$datnetA
       assert_that(is.count(p))
       self$p <- p
       nobs <- datnetW$nOdata
       # Copy variable detected types (bin, cat or contin) from the observed data classes (datnetW, datnetA) to self:
       self$copy.sVar.types()
-      if (is.null(f.g_name)) {  # set df.sWsA to observed data (sW,sA) if g.fun is.null
+      if (is.null(f.g_fun)) {  # set df.sWsA to observed data (sW,sA) if g.fun is.null
         df.sWsA <- cbind(datnetW$dat.sVar, datnetA$dat.sVar) # assigning summary measures as data.frames:
-      } else {  # need to sample A under f.g_name (gstar or known g0), possibly re-evaluate sW from O.datnetW
+      } else {  # need to sample A under f.g_fun (gstar or known g0), possibly re-evaluate sW from O.datnetW
         if (is.null(self$nodes$Anode)) stop("Anode was not appropriately specified and is null; can't replace observed Anode with that sampled under g_star")
         Odata <- datnetW$Odata
         # Will not be saving this object datnetA.gstar as self$datnetA (i.e., keeping a old pointer to O.datnetA)
         datnetA.gstar <- DatNet$new(netind_cl = datnetW$netind_cl, nodes = self$nodes)
         df.sWsA <- matrix(nrow = (nobs * p), ncol = (datnetW$ncols.sVar + datnetA$ncols.sVar))  # pre-allocate result matx sWsA
         colnames(df.sWsA) <- self$names.sWsA
         for (i in seq_len(p)) {
-          # *** f.g_name can only depend on covariates in datnetW$dat.sVar ***
+          # *** f.g_fun can only depend on covariates in datnetW$dat.sVar ***
           # if Anode is continuous, just call f.gen.probA.star:
 
-          A.gstar <- f.gen.A.star(data = cbind(datnetW$dat.sVar,datnetA$dat.sVar), fcn_name = f.g_name)
-          # A.gstar <- f.gen.A.star(k = self$Kmax, df_AllW = cbind(datnetW$dat.sVar,datnetA$dat.sVar), fcn_name = f.g_name)
-          # A.gstar <- f.gen.A.star.cont(k = self$Kmax, df_AllW = cbind(datnetW$dat.sVar,datnetA$dat.sVar), fcn_name = f.g_name, f_args = f.g_args)
+          A.gstar <- f.gen.A.star(data = cbind(datnetW$dat.sVar,datnetA$dat.sVar), f.g_fun = f.g_fun)
+          # A.gstar <- f.gen.A.star(k = self$Kmax, df_AllW = cbind(datnetW$dat.sVar,datnetA$dat.sVar), fcn_name = f.g_fun)
+          # A.gstar <- f.gen.A.star.cont(k = self$Kmax, df_AllW = cbind(datnetW$dat.sVar,datnetA$dat.sVar), fcn_name = f.g_fun, f_args = f.g_args)
 
           Odata[, self$nodes$Anode] <- A.gstar # replace A under g0 in Odata with A^* under g.star:
           datnetA.gstar$make.sVar(Odata = Odata, sVar.object = sA.object) # create new summary measures sA (under g.star)

R/Model_h.R

@@ -140,9 +140,9 @@ fit.hbars <- function(DatNet.ObsP0, est_params_list) {
   if (!is.null(f.g0)) {
     if (gvars$verbose) message("generating DatNet.g0 under known g0")
     DatNet.g0 <- DatNet.sWsA$new(datnetW = O.datnetW, datnetA = O.datnetA)
-    DatNet.g0$make.dat.sWsA(p = p_h0, f.g_name = f.g0, sA.object = sA)
+    DatNet.g0$make.dat.sWsA(p = p_h0, f.g_fun = f.g0, sA.object = sA)
     print("head(DatNet.g0$dat.sWsA): "); print(head(DatNet.g0$dat.sWsA))
-    # DatNet.g0$make.dat.sWsA(p = p_h0, f.g_name = f.g0, f.g_args = f.g0_args, sA.object = sA)
+    # DatNet.g0$make.dat.sWsA(p = p_h0, f.g_fun = f.g0, f.g_args = f.g0_args, sA.object = sA)
   } else {
     DatNet.g0 <- DatNet.ObsP0
   }
@@ -165,7 +165,7 @@ fit.hbars <- function(DatNet.ObsP0, est_params_list) {
 
   # *********
   # NEED TO PASS obsdat.sW.sA (observed data sWsA) to predict() funs.
-  # If !is.null(f.g_name) then DatNet.g0$dat.sWsA IS NOT THE OBSERVED data (sWsA), but rather sWsA data sampled under known g_0.
+  # If !is.null(f.g_fun) then DatNet.g0$dat.sWsA IS NOT THE OBSERVED data (sWsA), but rather sWsA data sampled under known g_0.
   # Option 1: Wipe out DatNet.g0$dat.sWsA with actually observed data - means that we can't use DatNet.g0$dat.sWsA in the future.
   # Option 2: Create a new class DatNet.Obs of DatNet.sWsA - pain in the ass...
   # Going with OPTION 1 for now:
@@ -180,8 +180,8 @@ fit.hbars <- function(DatNet.ObsP0, est_params_list) {
   }
 
   DatNet.gstar <- DatNet.sWsA$new(datnetW = O.datnetW, datnetA = O.datnetA)
-  DatNet.gstar$make.dat.sWsA(p = ng.MCsims, f.g_name = f.gstar, sA.object = sA)
-  # DatNet.gstar$make.dat.sWsA(p = ng.MCsims, f.g_name = f.gstar, f.g_args = f.g_args, sA.object = sA)
+  DatNet.gstar$make.dat.sWsA(p = ng.MCsims, f.g_fun = f.gstar, sA.object = sA)
+  # DatNet.gstar$make.dat.sWsA(p = ng.MCsims, f.g_fun = f.gstar, f.g_args = f.g_args, sA.object = sA)
 
   if (gvars$verbose) {
     print("Generated new summary measures by sampling A from f_gstar (DatNet.gstar): "); print(class(DatNet.gstar$dat.sWsA))

R/tmlenet.R

@@ -500,14 +500,16 @@ eval.summaries <- function( sW, sA, Kmax, data, IDnode = NULL, NETIDnode = NULL,
 #' @param NETIDmat Alternative method for network specification, ths must be a matrix (\code{ncol=Kmax},
 #'  \code{nrow=nrow(data)}), where each row \code{i} is a vector of \code{i}'s friends IDs or \code{i}'s friends row
 #'  numbers in \code{data} if \code{IDnode=NULL}. See Details.
-#' @param f_gstar1 Intervention function that returns a vector of counterfactual exposures evaluated based on the summary 
-#'  measures (\code{sW,sA}). The summary measures are passed under argument \code{"data"}, therefore this function 
-#'  must contain a named argument \code{"data"} in its signature. The interventions defined by \code{f_gstar1} can 
-#'  be static, dynamic or stochastic. See Details and Examples below. 
-#' @param f_gstar2 Function that retuns a vector of counterfactual exposures under alternative intervention. 
+#' @param f_gstar1 Either an function or a vector of counterfactual exposures. If a function is specified, it must return 
+#'  a vector of counterfactual exposures evaluated based on the summary measures matrix (\code{sW,sA}) passed as a named 
+#'  argument \code{"data"}, therefore, the function in \code{f_gstar1} must have a named argument \code{"data"} in its signature.
+#'  The interventions defined by \code{f_gstar1} can be static, dynamic or stochastic. If \code{f_gstar1} is specified as a 
+#'  vector, it must be of length \code{nrow(data)} or 1 (constant treatment assigned to all observations).
+#'  See Details below and Examples "EQUIVALENT WAYS OF SPECIFYING INTERVENTIONS \code{f_gstar1}/\code{f_gstar2}" for demonstration.
+#' @param f_gstar2 Either a function or a vector of counterfactual exposure assignments.
 #'  Used for estimating contrasts (average treatment effect) for two interventions, if omitted, only the average 
 #'  counterfactual outcome under intervention \code{f_gstar1} is estimated. The requirements for \code{f_gstar2}
-#'  are the same as for \code{f_gstar1}.
+#'  are identical to those for \code{f_gstar1}.
 # @param nFnode (Optional) Name of the variable for the number of friends each unit has, this name can then be used
 #  inside the summary measures and regression formulas \code{sW}, \code{sA}, \code{Qform}, \code{hform.g0},
 #  \code{hform.gstar} and \code{gform}. See Details.
@@ -591,7 +593,7 @@ eval.summaries <- function( sW, sA, Kmax, data, IDnode = NULL, NETIDnode = NULL,
 #'  (of length n*n_MCsims) from \code{f_g0};
 #' }
 #'
-#' @section Specifying the counterfactual intervention functions \code{f_gstar1} and \code{f_gstar2}:
+#' @section Specifying the counterfactual intervention as functions (\code{f_gstar1} and \code{f_gstar2}):
 #' The functions \code{f_gstar1} and \code{f_gstar2} can only depend on variables specified by the combined matrix
 #'  of summary measures (\code{sW},\code{sA}), which is passed using the argument \code{data}. The functions should
 #'  return a vector of length \code{nrow(data)} of counterfactual treatments for observations in the input data.

man/DatNet.sWsA.Rd

@@ -48,7 +48,7 @@ This class inherits from \code{DatNet} and extends its methods to handle a singl
   \item{\code{binirize.cat.sVar(name.sVar, levels)}}{...}
   \item{\code{get.sVar.bw(name.sVar, intervals)}}{...}
   \item{\code{get.sVar.bwdiff(name.sVar, intervals)}}{...}
-  \item{\code{make.dat.sWsA(p = 1, f.g_name = NULL, sA.object = NULL)}}{...}
+  \item{\code{make.dat.sWsA(p = 1, f.g_fun = NULL, sA.object = NULL)}}{...}
 }
 }