Cleaning, metadata

Author: ngreifer

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: WeightIt
 Type: Package
 Title: Weighting for Covariate Balance in Observational Studies
-Version: 1.5.1
+Version: 1.5.1.9000
 Authors@R: c(
     person("Noah", "Greifer", role=c("aut", "cre"), 
            email = "noah.greifer@gmail.com",
@@ -46,6 +46,7 @@ Suggests:
     gbm (>= 2.1.9),
     dbarts (>= 0.9-29),
     misaem (>= 1.0.1),
+    GPBayes,
     mlogit,
     dfidx,
     broom,

R/functions_for_processing.R

@@ -365,9 +365,9 @@
 
 .check_user_method <- function(method) {
   #Check to make sure it accepts treat and covs
-  if (all(c("covs", "treat") %in% names(formals(method)))) {
+  if (all(c("covs", "treat") %in% rlang::fn_fmls_names(method))) {
   }
-  # else if (all(c("covs.list", "treat.list") %in% names(formals(method)))) {
+  # else if (all(c("covs.list", "treat.list") %in% rlang::fn_fmls_names(method))) {
   # }
   else {
     .err("the user-provided function to `method` must contain `covs` and `treat` as named parameters")

R/glm_weightit_helpers.R

@@ -519,7 +519,7 @@
       ctrl <- stats::glm.control
     }
 
-    model_call[setdiff(names(model_call), c(names(formals(stats::glm)), names(formals(ctrl))))] <- NULL
+    model_call[setdiff(names(model_call), c(rlang::fn_fmls_names(stats::glm), rlang::fn_fmls_names(ctrl)))] <- NULL
   }
   else if (model == "lm") {
     model_call[[1L]] <- quote(stats::glm)
@@ -533,11 +533,11 @@
     model_call$na.action <- "na.fail"
     model_call$family <- "gaussian"
 
-    model_call[setdiff(names(model_call), c(names(formals(stats::glm)), names(formals(stats::glm.control))))] <- NULL
+    model_call[setdiff(names(model_call), c(rlang::fn_fmls_names(stats::glm), rlang::fn_fmls_names(stats::glm.control)))] <- NULL
   }
   else if (model == "ordinal") {
     model_call[[1L]] <- .ordinal_weightit
-    model_call[setdiff(names(model_call), names(formals(.ordinal_weightit)))] <- NULL
+    model_call[setdiff(names(model_call), rlang::fn_fmls_names(.ordinal_weightit))] <- NULL
 
     if (is_not_null(weightit)) {
       model_call$weights <- weightit[["weights"]] * weightit[["s.weights"]]
@@ -549,7 +549,7 @@
   }
   else if (model == "multinom") {
     model_call[[1L]] <- .multinom_weightit
-    model_call[setdiff(names(model_call), names(formals(.multinom_weightit)))] <- NULL
+    model_call[setdiff(names(model_call), rlang::fn_fmls_names(.multinom_weightit))] <- NULL
 
     if (is_not_null(weightit)) {
       model_call$weights <- weightit[["weights"]] * weightit[["s.weights"]]
@@ -571,7 +571,7 @@
     model_call$robust <- vcov == "HC0"
 
     model_call$cluster <- NULL
-    model_call[setdiff(names(model_call), c(names(formals(survival::coxph)), names(formals(survival::coxph.control))))] <- NULL
+    model_call[setdiff(names(model_call), c(rlang::fn_fmls_names(survival::coxph), rlang::fn_fmls_names(survival::coxph.control)))] <- NULL
   }
 
   model_call
@@ -774,7 +774,7 @@
     if (is_null(fwb.args$verbose)) {
       fwb.args$verbose <- FALSE
     }
-    fwb.args <- fwb.args[names(fwb.args) %in% names(formals(fwb::fwb))]
+    fwb.args <- fwb.args[names(fwb.args) %in% rlang::fn_fmls_names(fwb::fwb)]
 
     if (is_null(cluster)) {
       fwb_out <- eval(as.call(c(list(quote(fwb::fwb)), fwb.args)))

R/weightit2bart.R

@@ -209,8 +209,8 @@ weightit2bart <- function(covs, treat, s.weights, subset, estimand, focal, stabi
   t.lev <- get_treated_level(treat, estimand, focal)
   treat <- binarize(treat, one = t.lev)
 
-  A <- ...mget(setdiff(c(names(formals(dbarts::bart2)),
-                         names(formals(dbarts::dbartsControl))),
+  A <- ...mget(setdiff(c(rlang::fn_fmls_names(dbarts::bart2),
+                         rlang::fn_fmls_names(dbarts::dbartsControl)),
                        c("offset.test", "weights", "subset", "test")))
 
   A[["data"]] <- treat
@@ -227,7 +227,7 @@ weightit2bart <- function(covs, treat, s.weights, subset, estimand, focal, stabi
   error = function(e) {
     .err(sprintf("(from `dbarts::bart2()`): %s",
                  conditionMessage(e)),
-                 tidy = FALSE)
+         tidy = FALSE)
   })
 
   p.score <- fitted(fit)
@@ -256,8 +256,8 @@ weightit2bart.multi <-  function(covs, treat, s.weights, subset, estimand, focal
 
   ps <- make_df(levels(treat), nrow = length(treat))
 
-  A <- ...mget(setdiff(c(names(formals(dbarts::bart2)),
-                         names(formals(dbarts::dbartsControl))),
+  A <- ...mget(setdiff(c(rlang::fn_fmls_names(dbarts::bart2),
+                         rlang::fn_fmls_names(dbarts::dbartsControl)),
                        c("offset.test", "weights", "subset", "test")))
 
   A[["formula"]] <- covs
@@ -316,8 +316,8 @@ weightit2bart.cont <- function(covs, treat, s.weights, subset, stabilize, missin
                            density = ...get("density"),
                            weights = s.weights)
 
-  A <- ...mget(setdiff(c(names(formals(dbarts::bart2)),
-                         names(formals(dbarts::dbartsControl))),
+  A <- ...mget(setdiff(c(rlang::fn_fmls_names(dbarts::bart2),
+                         rlang::fn_fmls_names(dbarts::dbartsControl)),
                        c("offset.test", "weights", "subset", "test")))
 
   A[["formula"]] <- covs

R/weightit2energy.R

@@ -72,6 +72,7 @@
 #'   \item{`moments`}{`integer`; the highest power of each covariate to be balanced. For example, if `moments = 3`, each covariate, its square, and its cube will be balanced. Can also be a named vector with a value for each covariate (e.g., `moments = c(x1 = 2, x2 = 4)`). Values greater than 1 for categorical covariates are ignored. Default is 0 to impose no constraint on balance.}
 #'   \item{`int`}{`logical`; whether first-order interactions of the covariates are to be balanced. Default is `FALSE`.}
 #'   \item{`tols`}{when `moments` is positive, a number corresponding to the maximum allowed standardized mean difference (for binary and multi-category treatments) or treatment-covariate correlation (for continuous treatments) allowed. Default is 0. Ignored when `moments = 0`.}
+#'   \item{`min.w`}{the minimum allowable weight. Negative values (including `-Inf`) are allowed. Default is `1e-8`.}
 #' }
 #'
 #' For binary and multi-category treatments, the following additional arguments can be specified:
@@ -116,7 +117,7 @@
 #' @details
 #' Energy balancing is a method of estimating weights using
 #' optimization without a propensity score. The weights are the solution to a
-#' constrain quadratic optimization problem where the objective function
+#' constrained quadratic optimization problem where the objective function
 #' concerns covariate balance as measured by the energy distance and (for
 #' continuous treatments) the distance covariance.
 #'
@@ -260,6 +261,9 @@ weightit2energy <- function(covs, treat, s.weights, subset, estimand, focal,
   treat <- binarize(treat, one = t.lev)
 
   n <- length(treat)
+
+  sw0 <- check_if_zero(s.weights)
+
   diagn <- diag(n)
 
   covs <- scale(covs)
@@ -310,8 +314,16 @@ weightit2energy <- function(covs, treat, s.weights, subset, estimand, focal,
 
     #Constraints for positivity and sum of weights
     Amat <- cbind(diagn, s.weights_n_0, s.weights_n_1)
-    lvec <- c(rep.int(min.w, n), 1, 1)
-    uvec <- c(ifelse(check_if_zero(s.weights), min.w, Inf), 1, 1)
+    lvec <- c(ifelse(sw0, 1, min.w), 1, 1)
+    uvec <- c(ifelse(sw0, 1, Inf), 1, 1)
+
+    unbounded <- lvec == -Inf & uvec == Inf
+
+    if (any(unbounded)) {
+      Amat <- Amat[, !unbounded, drop = FALSE]
+      lvec <- lvec[!unbounded]
+      uvec <- uvec[!unbounded]
+    }
 
     if (add_constraints) {
       #Exactly balance moments, interactions, and/or quantiles
@@ -347,8 +359,16 @@ weightit2energy <- function(covs, treat, s.weights, subset, estimand, focal,
     q <- 2 * (s.weights_n_1[t1] %*% d[t1, t0, drop = FALSE]) * s.weights_n_0[t0]
 
     Amat <- cbind(diag(n0), s.weights_n_0[t0])
-    lvec <- c(rep.int(min.w, n0), 1)
-    uvec <- c(ifelse(check_if_zero(s.weights[t0]), min.w, Inf), 1)
+    lvec <- c(ifelse(sw0[t0], 1, min.w), 1)
+    uvec <- c(ifelse(sw0[t0], 1, Inf), 1)
+
+    unbounded <- lvec == -Inf & uvec == Inf
+
+    if (any(unbounded)) {
+      Amat <- Amat[, !unbounded, drop = FALSE]
+      lvec <- lvec[!unbounded]
+      uvec <- uvec[!unbounded]
+    }
 
     if (add_constraints) {
       #Exactly balance moments, interactions, and/or quantiles
@@ -384,8 +404,16 @@ weightit2energy <- function(covs, treat, s.weights, subset, estimand, focal,
     q <- 2 * (s.weights_n_0[t0] %*% d[t0, t1, drop = FALSE]) * s.weights_n_1[t1]
 
     Amat <- cbind(diag(n1), s.weights_n_1[t1])
-    lvec <- c(rep.int(min.w, n1), 1)
-    uvec <- c(ifelse(check_if_zero(s.weights[t1]), min.w, Inf), 1)
+    lvec <- c(ifelse(sw0[t1], 1, min.w), 1)
+    uvec <- c(ifelse(sw0[t1], 1, Inf), 1)
+
+    unbounded <- lvec == -Inf & uvec == Inf
+
+    if (any(unbounded)) {
+      Amat <- Amat[, !unbounded, drop = FALSE]
+      lvec <- lvec[!unbounded]
+      uvec <- uvec[!unbounded]
+    }
 
     if (add_constraints) {
       #Exactly balance moments, interactions, and/or quantiles
@@ -494,8 +522,8 @@ weightit2energy <- function(covs, treat, s.weights, subset, estimand, focal,
   }
 
   # Shrink tiny weights to 0
-  if (abs(min.w) < .Machine$double.eps) {
-    w[abs(w) < .Machine$double.eps] <- 0
+  if (abs(min.w) < 1e-10) {
+    w[abs(w) < 1e-10] <- 0
   }
 
   opt.out$lambda <- lambda
@@ -541,10 +569,12 @@ weightit2energy.multi <- function(covs, treat, s.weights, subset, estimand, foca
   s.weights <- s.weights[subset]
 
   n <- length(treat)
-  levels_treat <- levels(treat)
+
+  sw0 <- check_if_zero(s.weights)
+
   diagn <- diag(n)
 
-  covs <- scale(covs)
+  levels_treat <- levels(treat)
 
   min.w <- ...get("min.w", 1e-8)
   chk::chk_number(min.w)
@@ -561,6 +591,7 @@ weightit2energy.multi <- function(covs, treat, s.weights, subset, estimand, foca
     tols <- ...get("tols", 0)
     chk::chk_number(tols)
     tols <- abs(tols)
+    covs <- scale(covs)
   }
 
   treat_t <- matrix(0, nrow = n, ncol = length(levels_treat),
@@ -596,8 +627,16 @@ weightit2energy.multi <- function(covs, treat, s.weights, subset, estimand, foca
 
     #Constraints for positivity and sum of weights
     Amat <- cbind(diagn, s.weights_n_t)
-    lvec <- c(rep.int(min.w, n), rep.int(1, length(levels_treat)))
-    uvec <- c(ifelse(check_if_zero(s.weights), min.w, Inf), rep.int(1, length(levels_treat)))
+    lvec <- c(ifelse(sw0, 1, min.w), rep.int(1, length(levels_treat)))
+    uvec <- c(ifelse(sw0, 1, Inf), rep.int(1, length(levels_treat)))
+
+    unbounded <- lvec == -Inf & uvec == Inf
+
+    if (any(unbounded)) {
+      Amat <- Amat[, !unbounded, drop = FALSE]
+      lvec <- lvec[!unbounded]
+      uvec <- uvec[!unbounded]
+    }
 
     if (add_constraints) {
       #Exactly balance moments, interactions, and/or quantiles
@@ -639,8 +678,16 @@ weightit2energy.multi <- function(covs, treat, s.weights, subset, estimand, foca
       rowSums(s.weights_n_t[!in_focal, non_focal, drop = FALSE])
 
     Amat <- cbind(diag(sum(!in_focal)), s.weights_n_t[!in_focal, non_focal])
-    lvec <- c(rep.int(min.w, sum(!in_focal)), rep.int(1, length(non_focal)))
-    uvec <- c(ifelse(check_if_zero(s.weights[!in_focal]), min.w, Inf), rep.int(1, length(non_focal)))
+    lvec <- c(ifelse(sw0[!in_focal], 1, min.w), rep.int(1, length(non_focal)))
+    uvec <- c(ifelse(sw0[!in_focal], 1, Inf), rep.int(1, length(non_focal)))
+
+    unbounded <- lvec == -Inf & uvec == Inf
+
+    if (any(unbounded)) {
+      Amat <- Amat[, !unbounded, drop = FALSE]
+      lvec <- lvec[!unbounded]
+      uvec <- uvec[!unbounded]
+    }
 
     if (add_constraints) {
       #Exactly balance moments, interactions, and/or quantiles
@@ -734,8 +781,8 @@ weightit2energy.multi <- function(covs, treat, s.weights, subset, estimand, foca
   }
 
   # Shrink tiny weights to 0
-  if (abs(min.w) < .Machine$double.eps) {
-    w[abs(w) < .Machine$double.eps] <- 0
+  if (abs(min.w) < 1e-10) {
+    w[abs(w) < 1e-10] <- 0
   }
 
   opt.out$lambda <- lambda
@@ -860,8 +907,16 @@ weightit2energy.cont <- function(covs, treat, s.weights, subset, missing, verbos
   q[] <- q * s.weights
 
   Amat <- cbind(diag(n), s.weights)
-  lvec <- c(rep.int(min.w, n), n)
-  uvec <- c(ifelse(sw0, min.w, Inf), n)
+  lvec <- c(ifelse(sw0, 1, min.w), n)
+  uvec <- c(ifelse(sw0, 1, Inf), n)
+
+  unbounded <- lvec == -Inf & uvec == Inf
+
+  if (any(unbounded)) {
+    Amat <- Amat[, !unbounded, drop = FALSE]
+    lvec <- lvec[!unbounded]
+    uvec <- uvec[!unbounded]
+  }
 
   if (d.moments > 0) {
     d.covs <- .apply_moments_int_quantile(covs, moments = d.moments)
@@ -945,8 +1000,8 @@ weightit2energy.cont <- function(covs, treat, s.weights, subset, missing, verbos
   w <- opt.out$x
 
   # Shrink tiny weights to 0
-  if (abs(min.w) < .Machine$double.eps) {
-    w[abs(w) < .Machine$double.eps] <- 0
+  if (abs(min.w) < 1e-10) {
+    w[abs(w) < 1e-10] <- 0
   }
 
   opt.out$lambda <- lambda

man/dot-weightit_methods.Rd

@@ -1,12 +1,9 @@
 % Rd macro for simplifying documentation writing
 
-\newcommand{\fun}{\code{\link[=#1]{#1()}}}
-
 % Because R packages need conditional use of packages in Suggests, any cross-reference to a doc in another package needs to be conditionally evaluated, too.
 
 %\pkgfun{}{})tests whether the package is available, and, if so, produces a cross-reference to the function in the package; if not, the function name is displayed without a cross-reference. The first argument is the package, the second is the function name, e.g., \pkgfun{optmatch}{pairmatch}.
-\newcommand{\pkgfun}{\ifelse{\Sexpr[results=rd,stage=render]{requireNamespace("#1", quietly = TRUE)}}{\code{\link[#1:#2]{#1::#2()}}}{\code{#1::#2()}}}
-%\newcommand{\pkgfun}{\code{\link[#1:#2]{#2()}}}
+\newcommand{\pkgfun}{\Sexpr[results=rd,stage=render]{if (rlang::is_installed("#1")) r"(\code{\link[#1:#2]{#1::#2()}})" else r"(\code{#1::#2()})"}}
 
 %E.g., \pkgfun{sandwich}{vcovCL} is the same as \code{\link[sandwich:vcovCL]{vcovCL}} if the sandwich package is installed and \code{vcovCL} if not.