Nothing
R/x2base.R
In cobalt: Covariate Balance Tables and Plots
Defines functions
.x2base_default_msm
.x2base_default_point
x2base.default
x2base.weightitMSM
x2base.CBMSM
x2base.formula.list
x2base.data.frame.list
x2base.iptw
x2base.sbwcau
x2base.wimids
x2base.mimids
x2base.designmatch
x2base.weightit
x2base.cem.match
x2base.optmatch
x2base.ebalance
x2base.CBPS
x2base.data.frame
x2base.formula
x2base.Match
x2base.ps.cont
x2base.mnps
x2base.ps
x2base.matchit
x2base
#Functions to convert object to base.bal.tab input
x2base <- function(x, ...) {
UseMethod("x2base")
}
#' @exportS3Method NULL
x2base.matchit <- function(x, ...) {
#Process matchit
#Process data and get imp
m.data <- if (NROW(x[["model"]][["data"]]) == length(x[["treat"]])) x[["model"]][["data"]] else NULL
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, m.data)
#Process treat
treat <- process_treat(x[["treat"]], data, m.data)
#Process covs
if (is.data.frame(x[["X"]])) {
covs <- get_covs_from_formula(data = x[["X"]])
}
else if (is_not_null(x[["model"]][["model"]])) {
if (nrow(x[["model"]][["model"]]) == length(treat)) {
covs <- get_covs_from_formula(x[["formula"]], data = x[["model"]][["model"]])
}
else {
#Recreating covs from model object and x[["X"]]. Have to do this because when
#discard != NULL and reestimate = TRUE, cases are lost. This recovers them.
# if (is_not_null(data)) {
# covs <- get_covs_from_formula(x[["formula"]], data = x[["model"]][["model"]])
# }
# else {
order <- setNames(attr(x[["model"]][["terms"]], "order"),
attr(x[["model"]][["terms"]], "term.labels"))
assign <- setNames(attr(x[["X"]], "assign"), colnames(x[["X"]]))
assign1 <- assign[assign %in% which(order == 1)] #Just main effects
dataClasses <- attr(x[["model"]][["terms"]], "dataClasses")
factors.to.unsplit <- names(dataClasses)[dataClasses %in% c("factor", "character", "logical")]
f0 <- setNames(lapply(factors.to.unsplit,
function(z) {
if (dataClasses[z] == "factor")
list(levels = levels(x[["model"]][["model"]][[z]]),
faclev = paste0(z, levels(x[["model"]][["model"]][[z]])))
else
list(levels = unique(x[["model"]][["model"]][[z]]),
faclev = paste0(z, unique(x[["model"]][["model"]][[z]])))
}),
factors.to.unsplit)
covs <- as.data.frame(x[["X"]][, names(assign1)])
for (i in factors.to.unsplit) {
covs <- unsplitfactor(covs, i, sep = "",
dropped.level = f0[[i]][["levels"]][f0[[i]][["faclev"]] %nin% colnames(x[["X"]])])
if (dataClasses[i] == "logical") {
covs[[i]] <- as.logical(covs[[i]])
}
}
covs <- get_covs_from_formula(x[["formula"]], data = covs)
# }
}
}
else if (is_not_null(x[["formula"]]) && is_not_null(data)) {
covs <- get_covs_from_formula(x[["formula"]], data = data)
}
else {
covs <- get_covs_from_formula(data = x[["X"]])
}
#Get estimand
estimand <- ...get("estimand", x[["estimand"]])
#Get method
if (inherits(x, "matchit.subclass")) {
method <- ...get("method")
method <- {
if (is_null(method) || !chk::vld_string(method)) "subclassification"
else match_arg(method, c("weighting", "subclassification"))
}
}
else {
method <- "matching"
}
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, m.data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, m.data, covs),
obj.distance = x[["distance"]],
obj.distance.name = "distance")
#Process focal
focal <- x[["focal"]]
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with matchit objects")
}
subclass <- switch(method,
"subclassification" = as.factor(x[["subclass"]]),
NULL)
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with matchit objects")
}
#Process weights
if (is_not_null(x[["weights"]]) && !all_the_same(x[["weights"]])) {
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, m.data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["s.weights"]]),
data, m.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, m.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- x[["discarded"]]
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "matchit()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.ps <- function(x, ...) {
#Process ps
stop.method <- ...get("stop.method")
if (is_null(stop.method) && ...length() > 0L && !nzchar(...names()[1L])) {
stop.method <- ...elt(1L)
}
if (is_null(stop.method) && is_not_null(...get("full.stop.method"))) {
stop.method <- ...get("full.stop.method")
}
available.stop.methods <- names(x[["w"]])
if (is_null(stop.method)) {
rule1 <- available.stop.methods
}
else if (is.character(stop.method)) {
rule1 <- available.stop.methods[vapply(tolower(available.stop.methods),
function(z) any(startsWith(z, tolower(stop.method))), logical(1L))]
if (is_null(rule1)) {
.wrn(sprintf("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L)))
rule1 <- available.stop.methods
}
}
else if (is.numeric(stop.method) && any(stop.method %in% seq_along(available.stop.methods))) {
if (!all(stop.method %in% seq_along(available.stop.methods))) {
.wrn(sprintf("there are %s stop methods available, but you requested %s",
length(available.stop.methods),
word_list(setdiff(stop.method, seq_along(available.stop.methods)), and.or = "and")))
}
rule1 <- available.stop.methods[stop.method %in% seq_along(available.stop.methods)]
}
else {
.wrn("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L))
rule1 <- available.stop.methods
}
s <- available.stop.methods[match(tolower(rule1), tolower(available.stop.methods))]
#Process data and get imp
ps.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, ps.data)
#Process treat
treat <- process_treat(x[["treat"]], data, ps.data)
#Process covs
if (is_not_null(x[["gbm.obj"]][["var.names"]])) {
covs <- reformulate(x[["gbm.obj"]][["var.names"]]) |>
get_covs_from_formula(data = ps.data)
}
else if (is_not_null(...get("formula")) || is_not_null(...get("covs"))) {
t.c <- .use_tc_fd(formula = ...get("formula"),
data = if_null_then(data, ps.data),
covs = ...get("covs"),
needs.treat = FALSE)
#Process covs
covs <- t.c[["covs"]]
}
else if (all(x[["gbm.obj"]][["feature_names"]] %in% names(ps.data))) {
covs <- reformulate(x[["gbm.obj"]][["feature_names"]]) |>
get_covs_from_formula(data = ps.data)
}
else {
.err('when `version = "xgboost"` in the call to `ps()` and any variables are categorical, `formula` or `covs` must be supplied')
}
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- rep.int("weighting", length(s))
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, ps.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, ps.data, covs),
obj.distance = x[["ps"]][s],
obj.distance.name = {
if (length(s) > 1L) paste.("prop.score", substr(s, 1L, nchar(s) - 4L))
else "prop.score"
})
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with ps objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with ps objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with ps objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, ps.data),
stop.method = s, estimand = estimand)
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["sampw"]]),
data, ps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, ps.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "ps()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
# call <- ps[["parameters"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.mnps <- function(x, ...) {
#Process mnps
stop.method <- ...get("stop.method")
if (is_null(stop.method) && ...length() > 0L && !nzchar(...names()[1L])) {
stop.method <- ...elt(1L)
}
if (is_null(stop.method) && is_not_null(...get("full.stop.method"))) {
stop.method <- ...get("full.stop.method")
}
available.stop.methods <- x[["stopMethods"]]
if (is_null(stop.method)) {
rule1 <- available.stop.methods
}
else if (is.character(stop.method)) {
rule1 <- available.stop.methods[vapply(tolower(available.stop.methods),
function(z) any(startsWith(z, tolower(stop.method))), logical(1L))]
if (is_null(rule1)) {
.wrn(sprintf("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L)))
rule1 <- available.stop.methods
}
}
else if (is.numeric(stop.method) && any(stop.method %in% seq_along(available.stop.methods))) {
if (!all(stop.method %in% seq_along(available.stop.methods))) {
.wrn(sprintf("there are %s stop methods available, but you requested %s",
length(available.stop.methods),
word_list(setdiff(stop.method, seq_along(available.stop.methods)), and.or = "and")))
}
rule1 <- available.stop.methods[stop.method %in% seq_along(available.stop.methods)]
}
else {
.wrn("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2))
rule1 <- available.stop.methods
}
s <- available.stop.methods[match(tolower(rule1), tolower(available.stop.methods))]
#Process data and get imp
mnps.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, mnps.data)
#Process treat
treat <- process_treat(x[["treatVar"]], data, mnps.data)
#Process covs
.v <- if_null_then(x[["balanceVars"]],
x[["psList"]][[1L]][["gbm.obj"]][["var.names"]])
covs <- get_covs_from_formula(reformulate(.v), mnps.data)
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- rep.int("weighting", length(s))
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, mnps.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, mnps.data))
#Process focal
focal <- x[["treatATT"]]
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with mnps objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with mnps objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, mnps.data),
stop.method = s)
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["sampw"]]),
data, mnps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, mnps.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "mnps()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("multi")
}
#' @exportS3Method NULL
x2base.ps.cont <- function(x, ...) {
#Process data and get imp
ps.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, ps.data)
#Process treat
treat <- process_treat(x[["treat"]], data, ps.data)
#Process covs
covs <- reformulate(x[["gbm.obj"]][["var.names"]]) |>
get_covs_from_formula(ps.data)
#Get estimand
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, ps.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, ps.data))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with ps.cont objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with ps.cont objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with ps.cont objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, ps.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["sampw"]]),
data, ps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, ps.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "ps.cont()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
# call <- ps.cont[["parameters"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("cont")
}
#' @exportS3Method NULL
x2base.Match <- function(x, ...) {
#Process Match
if (is_not_null(x) && !is.list(x)) {
.err("the supplied Match object contains no valid matches")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data, ...get("treat"), ...get("covs"))
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with Match objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with Match objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with Match objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- rep.int(FALSE, length(treat))
if (is_not_null(x[["index.dropped"]])) {
discarded[x[["index.dropped"]]] <- TRUE
}
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "Match()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.formula <- function(x, ...) {
x2base.data.frame(x = x, ...)
}
#' @exportS3Method NULL
x2base.data.frame <- function(x, ...) {
#Process data.frame
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
treat <- {
if (rlang::is_formula(x))
get_treat_from_formula(x, data, treat = ...get("treat"))
else
...get("treat")
}
treat <- process_treat(treat, data)
#Process covs
covs <- x
if (is.null(covs)) {
.err("`covs` data.frame must be specified")
}
if (rlang::is_formula(covs)) {
covs <- get_covs_from_formula(covs, data = data)
# if (is_null(covs)) {
# .err("The right hand side of the formula must contain covariates for which balance is to be assessed")
# }
}
if (is_null(attr(covs, "co.names"))) {
if (is.matrix(covs)) covs <- as.data.frame.matrix(covs)
covs <- get_covs_from_formula(data = covs)
}
#Get estimand
estimand <- ...get("estimand")
#Get method
specified <- setNames(rep.int(FALSE, 3L), c("match.strata", "subclass", "weights"))
for (i in names(specified)) {
specified[i] <- is_not_null(...get(i))
}
.specified_method <- character()
.specified_args <- character()
.assuming <- character()
.ignoring <- character()
.not_present <- character()
.using <- character()
method <- ...get("method")
if (is_null(method)) {
if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.assuming <- method
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else {
method <- "weighting"
}
}
else {
.specified_method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
if (length(method) == 1L) {
if (.specified_method == "weighting") {
if (specified["weights"]) {
method <- "weighting"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "weights"
}
else {
method <- "matching"
}
}
else if (.specified_method == "matching") {
if (specified["match.strata"]) {
method <- "matching"
.using <- "match.strata"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["weights"]) {
method <- "matching"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
.not_present <- c("weights", "match.strata")
.assuming <- method
}
else {
method <- "matching"
}
}
else if (.specified_method == "subclassification") {
if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "subclass"
}
else {
method <- "matching"
}
}
}
else {
if (specified["subclass"] || any(.specified_method == "subclassification")) {
.err("subclassification cannot be specified along with other methods")
}
if (specified["match.strata"]) {
.err("only weights can be specified with multiple methods")
}
if (specified["weights"]) {
method <- .specified_method
.using <- "weights"
}
else {
.wrn("multiple methods were specified, but no weights were provided. Providing unadjusted data only")
method <- "matching"
}
}
}
.m <- NULL
if (is_not_null(.using)) {
if (is_not_null(.specified_args) && is_not_null(.ignoring)) {
if (is_not_null(.assuming)) {
.m <- sprintf("%s specified. Assuming %s and using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
else {
.m <- sprintf("%s specified. Using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
}
else if (is_not_null(.specified_method) && is_not_null(.not_present) && is_not_null(.assuming)) {
.m <- sprintf("`method = %s` is specified, but %s was not supplied. Assuming %s and using %s instead",
add_quotes(.specified_method, 2L),
add_quotes(.not_present, "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"))
}
}
if (is_not_null(.m)) {
.msg(.m)
}
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- process_focal(...get("focal"), treat)
if (get.treat.type(treat) == "binary") {
if (is_null(focal) && is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if ("subclass" %in% .using) {
subclass <- .process_vector(...get("subclass"),
datalist = list(data),
name = "subclass",
which = "subclass membership",
missing.okay = TRUE) |>
factor()
weights <- NULL
}
#Process match.strata
if ("match.strata" %in% .using) {
match.strata <- .process_vector(...get("match.strata"),
datalist = list(data),
name = "match.strata",
which = "matching strata membership",
missing.okay = TRUE)
weights <- data.frame(weights = strata2weights(match.strata,
treat = treat,
estimand = estimand,
focal = focal))
}
#Process weights
if ("weights" %in% .using) {
weights <- process_weights(NULL, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- ...get("discarded")
#Process length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.CBPS <- function(x, ...) {
#Process CBPS
#Process data and get imp
c.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, c.data)
#Process treat
treat <- get_treat_from_formula(x[["formula"]], c.data) |>
process_treat(data, c.data)
#Process covs
covs <- get_covs_from_formula(x[["formula"]], c.data)
#Get estimand
estimand <- ...get("estimand")
if (is_not_null(estimand)) {
.err("`estimand` is not allowed with CBPS objects")
}
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, c.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, c.data),
obj.distance = if (get.treat.type(treat) == "binary") x[["fitted.values"]],
obj.distance.name = "prop.score")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with CBPS objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with CBPS objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with CBPS objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, c.data),
use.weights = ...get("use.weights"))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"),
data, c.data)
if (is_not_null(s.weights)) {
weights <- weights / s.weights #Because CBPS weights contain s.weights in them
}
#Process cluster
cluster <- process_cluster(...get("cluster"), data, c.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "CBPS()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.ebalance <- function(x, ...) {
#Process ebalance
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data, ...get("treat"), ...get("covs"))
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- "ATT"
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with ebalance objects")
}
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with ebalance objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with ebalance objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "ebalance()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.optmatch <- function(x, ...) {
#Process optmatch
if (all(is.na(x))) {
.err("the supplied optmatch abject contains no valid matches")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data = data, covs = ...get("covs"),
treat = ...get("treat", as.numeric(attr(x, "contrast.group"))))
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- ...get("estimand", "ATT")
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with optmatch objects")
}
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with optmatch objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with optmatch objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = sprintf("%s()", deparse1(attr(x, "call")[[1L]])))
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- attr(x, "call")
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.cem.match <- function(x, ...) {
#Process cem.match
if (inherits(x, "cem.match.list")) {
x[["vars"]] <- x[[1L]][["vars"]]
x[["baseline.group"]] <- x[[1L]][["baseline.group"]]
x[["groups"]] <- unlist(grab(x[vapply(x, inherits, logical(1L), "cem.match")], "groups"))
x[["w"]] <- get.w.cem.match(x)
}
if (all(check_if_zero(x[["w"]]))) {
.err("the supplied cem.match object contains no valid matches")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
if (is_null(data)) {
.err("an argument to `data` must be specified with cem.match objects")
}
#Process imp
imp <- process_imp(imp, data)
if (is_null(imp) && inherits(x, "cem.match.list") &&
sum(vapply(x, is_, logical(1L), "cem.match")) != 1L) {
.err("an argument to `imp` must be specified or the argument to data must be a mids object")
}
#Process treat
t.c <- .use_tc_fd(data = data, treat = x[["groups"]],
covs = x[["vars"]])
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- ...get("estimand")
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with cem.match objects")
}
#Process focal
focal <- x[["baseline.group"]]
#Process pairwise
if (get.treat.type(treat) == "binary" && is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with cem.match objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "cem()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.weightit <- function(x, ...) {
#Process weightit
#Process data and get imp
d.e.in.w <- vapply(c("covs", "exact", "by", "moderator"), function(z) is_not_null(x[[z]]), logical(1L))
if (any(d.e.in.w)) weightit.data <- do.call("data.frame", unname(x[c("covs", "exact", "by", "moderator")[d.e.in.w]]))
else weightit.data <- NULL
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, weightit.data)
#Process treat
treat <- process_treat(x[["treat"]], data, weightit.data)
#Process covs
covs <- x[["covs"]]
if (is_not_null(covs)) {
covs <- get_covs_from_formula(data = covs)
}
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, weightit.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, weightit.data),
obj.distance = if (get.treat.type(treat) == "binary") x[["ps"]],
obj.distance.name = "prop.score")
#Process focal
focal <- x[["focal"]]
#Process pairwise
if (get.treat.type(treat) == "binary" && is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with weightit objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with weightit objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, weightit.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["s.weights"]]),
data, weightit.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, weightit.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- x[["discarded"]]
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "weightit()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.designmatch <- function(x, ...) {
#Process designmatch
if (all(c("id_1", "id_2") %in% names(x))) {
.err("Balance cannot currently be checked on a nonbipartite match")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data, ...get("treat"), ...get("covs"))
treat <- process_treat(t.c[["treat"]], data)
if (is.unsorted(rev(treat))) {
.wrn("designmatch requires the input data to be sorted by treatment; the data supplied to `bal.tab()` was not, indicating a possible coding error")
}
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- ...get("estimand")
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with designmatch objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with designmatch objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with designmatch objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "the matching function in designmatch")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.mimids <- function(x, ...) {
#Process mimids
old_version <- !all(c("object", "models", "approach") %in% names(x))
models <- if (old_version) x[["models"]][-1L] else x[["models"]]
#Process data and get imp
m.data <- {
if (!old_version) .mids_complete(x[["object"]])
else if (inherits(x[["original.datasets"]], "mids")) .mids_complete(x[["original.datasets"]])
else .mids_complete(x[["others"]][["source"]])
}
imp <- m.data[[".imp"]]
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
# .wrn("The argument to data is not a data.frame and will be ignored. If the argument to treat is not a vector, the execution will halt")
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, m.data)
#Process treat
treat <- process_treat(unlist(grab(models, "treat")))
#Process covs
covs <- do.call("rbind", grab(models, "X"))
covs <- get_covs_from_formula(data = covs)
#Get estimand
estimand <- models[[1L]][["estimand"]]
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, m.data))
#Process distance
m.distance <- unlist(grab(models, "distance"))
if (all(is.na(m.distance))) m.distance <- NULL
distance <- process_distance(...get("distance"), datalist = list(data, m.data),
obj.distance = m.distance,
obj.distance.name = "distance")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with mimids objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with mimids objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with mimids objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, m.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", unlist(grab(models, "s.weights"))),
data, m.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, m.data)
#Process subset
subset <- process_subset(...get("subset"), min(table(imp)))
#Process discarded
discarded <- unlist(grab(models, "discarded"))
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "matchthem()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("imp")
}
#' @exportS3Method NULL
x2base.wimids <- function(x, ...) {
#Process wimids
old_version <- !all(c("object", "models", "approach") %in% names(x))
models <- if (old_version) x[["models"]][-1L] else x[["models"]]
#Process data and get imp
w.data <- {
if (!old_version) .mids_complete(x[["object"]])
else if (inherits(x[["original.datasets"]], "mids")) .mids_complete(x[["original.datasets"]])
else .mids_complete(x[["others"]][["source"]])
}
imp <- w.data[[".imp"]]
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
# .wrn("The argument to data is not a data.frame and will be ignored. If the argument to treat is not a vector, the execution will halt")
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, w.data)
#Process treat
treat <- process_treat(unlist(grab(models, "treat")))
#Process covs
covs <- do.call("rbind", grab(models, "covs"))
covs <- get_covs_from_formula(data = covs)
#Get estimand
estimand <- unique(unlist(grab(models, "estimand")))
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, w.data))
#Process distance
w.distance <- unlist(grab(models, "ps"))
if (all(is.na(w.distance))) w.distance <- NULL
distance <- process_distance(...get("distance"), datalist = list(data, w.data),
obj.distance = if (get.treat.type(treat) == "binary") w.distance,
obj.distance.name = "prop.score")
#Process focal
focal <- unique(unlist(grab(models, "focal")))
#Process pairwise
if (get.treat.type(treat) == "binary" && is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with wimids objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with wimids objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, w.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", unlist(grab(models, "s.weights"))),
data, w.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, w.data)
#Process subset
subset <- process_subset(...get("subset"), min(table(imp)))
#Process discarded
discarded <- unlist(grab(models, "discarded"))
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "weightthem()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("imp")
}
#' @exportS3Method NULL
x2base.sbwcau <- function(x, ...) {
#Process sbwcau
#Process data and get imp
sbw.data <- x[["dat_weights"]][names(x[["dat_weights"]]) != "weights"]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, sbw.data)
#Process treat
treat <- process_treat(x[["ind"]], data, sbw.data)
#Process covs
covs <- reformulate(x[["bal"]][["bal_cov"]]) |>
get_covs_from_formula(data = sbw.data)
#Get estimand
estimand <- x[["par"]][["par_est"]]
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, sbw.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, sbw.data))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with sbwcau objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with sbwcau objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with sbwcau objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, sbw.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data, sbw.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, sbw.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "sbw()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#MSMs wth multiple time points
#' @exportS3Method NULL
x2base.iptw <- function(x, ...) {
#Process iptw
stop.method <- ...get("stop.method")
if (is_null(stop.method) && ...length() > 0L && !nzchar(...names()[1L])) {
stop.method <- ...elt(1L)
}
if (is_null(stop.method) && is_not_null(...get("full.stop.method"))) {
stop.method <- ...get("full.stop.method")
}
available.stop.methods <- names(x[["psList"]][[1L]][["ps"]])
if (is_null(stop.method)) {
rule1 <- available.stop.methods
}
else if (is.character(stop.method)) {
rule1 <- available.stop.methods[vapply(tolower(available.stop.methods),
function(z) any(startsWith(z, tolower(stop.method))), logical(1L))]
if (is_null(rule1)) {
.wrn(sprintf("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L)))
rule1 <- available.stop.methods
}
}
else if (is.numeric(stop.method) && any(stop.method %in% seq_along(available.stop.methods))) {
if (!all(stop.method %in% seq_along(available.stop.methods))) {
.wrn(sprintf("there are %s stop methods available, but you requested %s",
length(available.stop.methods),
word_list(setdiff(stop.method, seq_along(available.stop.methods)), and.or = "and")))
}
rule1 <- available.stop.methods[stop.method %in% seq_along(available.stop.methods)]
}
else {
.wrn("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L))
rule1 <- available.stop.methods
}
s <- available.stop.methods[match(tolower(rule1), tolower(available.stop.methods))]
#Process data and get imp
ps.data <- x[["psList"]][[1L]][["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, ps.data)
#Process treat.list
treat.list <- process_treat.list(grab(x[["psList"]], "treat"), data, ps.data)
#Process covs.list
if (all_apply(x[["psList"]], function(z) is_not_null(z[["gbm.obj"]][["var.names"]]))) {
covs.list <- lapply(x[["psList"]], function(z) {
reformulate(z[["gbm.obj"]][["var.names"]]) |>
get_covs_from_formula(data = z[["data"]])
})
}
else if (is_not_null(...get("formula.list")) || is_not_null(...get("covs.list"))) {
covs.list <- ...get("covs.list")
if (is_not_null(covs.list)) {
if (!is.list(covs.list) || is.data.frame(covs.list)) {
.err("`covs.list` must be a list of covariates for which balance is to be assessed at each time point")
}
if (!all_apply(covs.list, is_mat_like)) {
.err("each item in `covs.list` must be a data frame")
}
if (length(covs.list) != length(x[["psList"]])) {
.err("`covs.list` must have as many entries as time points in the call to `iptw()`")
}
}
formula.list <- ...get("formula.list")
if (is_not_null(formula.list)) {
if (!is.list(formula.list) || !all_apply(formula.list, rlang::is_formula)) {
.err("`formula.list` must be a list of formulas identifying the covariates for which balance is to be assessed at each time point")
}
if (length(formula.list) != length(x[["psList"]])) {
.err("`formula.list` must have as many entries as time points in the call to `iptw()`")
}
}
covs.list <- lapply(seq_along(x[["psList"]]), function(i) {
.use_tc_fd(formula = formula.list[[i]],
data = if_null_then(data, x[["psList"]][[i]][["data"]]),
covs = covs.list[[i]],
needs.treat = FALSE)[["covs"]]
})
}
else if (all_apply(x[["psList"]], function(z) all(z[["gbm.obj"]][["feature_names"]] %in% names(z[["data"]])))) {
covs.list <- lapply(x[["psList"]], function(z) {
reformulate(z[["gbm.obj"]][["feature_names"]]) |>
get_covs_from_formula(data = z[["data"]])
})
}
else {
.err('when `version = "xgboost"` in the call to `iptw()` and any variables are categorical, `formula.list` or `covs.list` must be supplied')
}
#Get estimand
estimand <- substr(toupper(s), nchar(s) - 2L, nchar(s))
#Get method
method <- rep.int("weighting", length(s))
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, ps.data),
covs.list = covs.list)
#Process distance
# ntimes <- iptw[["nFits"]]
# distance.list <- .process_list("distance.list", ...get("distance.list"), ntimes,
# "the original call to iptw()",
# treat.list,
# covs.list,
# list(data, ps.data))
# if (is_not_null(distance.list)) {
# for (ti in seq_along(distance.list)) {
# if (length(s) == 1) {
# distance.list[[ti]] <- data.frame(distance[[ti]], prop.score = iptw[["psList"]][[ti]][["ps"]][[s]])
# }
# else {
# distance.list[[ti]] <- data.frame(distance[[ti]], prop.score = iptw[["psList"]][[ti]][["ps"]][s])
# }
# }
#
# }
# else {
# distance.list <- make_list(ntimes)
# for (ti in seq_along(distance.list)) {
# if (length(s) == 1) {
# distance.list[[ti]] <- data.frame(prop.score = iptw[["psList"]][[ti]][["ps"]][[s]])
# }
# else {
# distance.list[[ti]] <- data.frame(prop.score = iptw[["psList"]][[ti]][["ps"]][s])
# }
# }
# }
# if (is_not_null(distance.list)) distance.list <- lapply(distance.list, function(z) get_covs_from_formula(~z))
#
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data, ps.data),
covs.list = covs.list,
obj.distance = lapply(x[["psList"]], function(z) z[["ps"]][, s, drop = FALSE]),
obj.distance.name = {
if (length(s) > 1L) paste.("prop.score", substr(s, 1L, nchar(s) - 4L))
else "prop.score"
})
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with iptw objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with iptw objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with iptw objects")
}
#Process weights
weights <- process_weights(x, list(...), treat.list[[1L]], covs.list[[1L]],
method, addl.data = list(data, ps.data),
stop.method = s)
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["psList"]][[1L]][["sampw"]]),
data, ps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, ps.data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp,
original.call.to = "iptw()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.data.frame.list <- function(x, ...) {
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat.list
treat.list <- process_treat.list(...get("treat.list"), data)
#Process covs.list
covs.list <- x
if (is_null(covs.list)) {
.err("`covs.list` must be specified")
}
if (!is.list(covs.list) || is.data.frame(covs.list)) {
.err("`covs.list` must be a list of covariates for which balance is to be assessed at each time point")
}
if (!all_apply(covs.list, is_mat_like)) {
.err("each item in `covs.list` must be a data frame")
}
if (any_apply(covs.list, function(z) is_null(attr(z, "co.names")))) {
covs.list <- lapply(covs.list, function(z) get_covs_from_formula(data = z))
}
if (length(treat.list) != length(covs.list)) {
.err("`treat.list` must be a list of treatment statuses at each time point")
}
#Get estimand
estimand <- "ATE"
#Get method
specified <- setNames(rep.int(FALSE, 1L), "weights")
if (is_not_null(...get("weights"))) {
if (!is_(...get("weights"), c("character", "numeric", "data.frame", "list"))) {
.err("the argument to `weights` must be a vector, list, or data frame of weights or the (quoted) names of variables in `data` that contain weights")
}
specified["weights"] <- TRUE
}
method <- ...get("method")
if (is_null(method)) {
method <- if (specified["weights"]) "weighting" else "matching"
}
else if (length(method) == 1L) {
specified.method <- match_arg(method, c("weighting", "matching", "subclassification"))
if (specified.method == "weighting") {
method <- if (specified["weights"]) "weighting" else "matching"
}
else if (specified["weights"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
method <- "weighting"
}
else {
method <- "matching"
}
}
else {
specified.method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
if (any(specified.method == "subclassification") || specified["subclass"] || specified["match.strata"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
method <- "weighting"
}
else if (specified["weights"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
method <- "weighting"
}
# else if (!specified["weights"]) {
# #Should never happen
# .wrn("multiple methods were specified, but no weights were provided. Providing unadjusted data only")
# method <- "matching"
# }
else {
method <- "matching"
}
}
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data),
covs.list = covs.list)
#Process distance
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data),
covs.list = covs.list)
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with longitudinal treatments")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with longitudinal treatments")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with longitudinal treatments")
}
#Process weights
weights <- ...get("weights")
if (is_not_null(weights)) {
weights <- process_weights(NULL, list(...), treat.list[[1L]], covs.list[[1L]],
method, addl.data = list(data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("msm")
}
#' @exportS3Method NULL
x2base.formula.list <- function(x, ...) {
treat.list <- covs.list <- make_list(length(x))
for (i in seq_along(x)) {
treat.list[[i]] <- get_treat_from_formula(x[[i]], data = ...get("data"))
covs.list[[i]] <- get_covs_from_formula(x[[i]], data = ...get("data"))
names(treat.list)[i] <- attr(treat.list[[i]], "treat.name")
}
if ("treat.list" %in% ...names()) {
A <- list(...)
A[["x"]] <- covs.list
A[["treat.list"]] <- treat.list
return(do.call("x2base.data.frame.list", A))
}
x2base.data.frame.list(covs.list, treat.list = treat.list, ...)
}
#' @exportS3Method NULL
x2base.CBMSM <- function(x, ...) {
#Process CBMSM
ID <- sort(unique(x[["id"]]))
times <- sort(unique(x[["time"]]))
x[["data"]] <- x[["data"]][order(x[["id"]], x[["time"]]), ,drop = FALSE]
#Process data and get imp
cbmsm.data <- x[["data"]][x[["time"]] == 1, , drop = FALSE]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat.list
treat.list <- process_treat.list(lapply(times, function(z) x[["treat.hist"]][ID, z]),
data, cbmsm.data)
#Process covs.list
covs.list <- make_list(times)
for (i in seq_along(times)) {
ti <- times[i]
cov_i <- get_covs_from_formula(x[["formula"]], data = x[["data"]][x[["time"]] == ti, , drop = FALSE])
for (co in seq_along(attr(cov_i, "co.names"))) {
attr(cov_i, "co.names")[[co]][["component"]][attr(cov_i, "co.names")[[co]][["type"]] == "base"] <-
paste0(attr(cov_i, "co.names")[[co]][["component"]][attr(cov_i, "co.names")[[co]][["type"]] == "base"], "_T", ti)
}
names(attr(cov_i, "co.names")) <- vapply(attr(cov_i, "co.names"), function(z) paste(z[["component"]], collapse = ""), character(1L))
colnames(cov_i) <- names(attr(cov_i, "co.names"))
covs.list[[i]] <- {
if (i == 1L) cov_i
else co.cbind(covs.list[[i - 1L]], cov_i)
}
}
#Get estimand
estimand <- "ATE"
#Get method
method <- "weighting"
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, cbmsm.data),
covs.list = covs.list)
#Process distance
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data, cbmsm.data),
covs.list = covs.list, obj.distance = x[["fitted.values"]],
obj.distance.name = "prop.score")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with CBMSM objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with CBMSM objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with CBMSM objects")
}
#Process weights
weights <- process_weights(x, list(...), treat.list[[1L]], covs.list[[1L]], method,
addl.data = list(data, cbmsm.data))
method <- attr(weights, "method")
#Process s.weights
if (is_not_null(...get("s.weights"))) {
.err("sampling weights are not allowed with CBMSM objects")
}
#Process cluster
cluster <- process_cluster(...get("cluster"), data, cbmsm.data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp,
original.call.to = "CBMSM()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.weightitMSM <- function(x, ...) {
#Process weightitMSM
#Process data and get imp
weightitMSM.data <- x[["data"]]
d.e.in.w <- vapply(c("exact", "by", "moderator"), function(z) is_not_null(x[[z]]), logical(1L))
weightitMSM.data2 <- {
if (any(d.e.in.w)) do.call("data.frame", unname(x[c("exact", "by", "moderator")[d.e.in.w]]))
else NULL
}
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, weightitMSM.data, weightitMSM.data2)
#Process treat.list
treat.list <- process_treat.list(x[["treat.list"]],
data, weightitMSM.data, weightitMSM.data2)
#Process covs.list
covs.list <- lapply(x[["covs.list"]], function(z) get_covs_from_formula(data = z))
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- "weighting"
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, weightitMSM.data,
weightitMSM.data2),
covs.list = covs.list)
#Process distance
# ntimes <- length(covs.list)
# distance.list <- .process_list("distance.list", ...get("distance.list"), ntimes,
# "the original call to weightitMSM()",
# treat.list,
# covs.list,
# list(data, weightitMSM.data,
# weightitMSM.data2))
# if (is_not_null(distance.list)) distance.list <- lapply(seq_along(distance.list), function(z) data.frame(distance.list[[z]], prop.score = weightitMSM[["ps.list"]][[z]]))
# else if (is_not_null(weightitMSM[["ps.list"]])) distance.list <- lapply(seq_along(weightitMSM[["ps.list"]]), function(z) data.frame(prop.score = weightitMSM[["ps.list"]][[z]]))
# else distance.list <- NULL
# if (is_not_null(distance.list)) distance.list <- lapply(distance.list, function(z) get_covs_from_formula(~z))
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data, weightitMSM.data, weightitMSM.data2),
covs.list = covs.list, obj.distance = x[["ps.list"]],
obj.distance.name = "prop.score")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with weightitMSM objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with weightitMSM objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with weightitMSM objects")
}
#Process weights
weights <- process_weights(x, list(...), treat.list[[1L]], covs.list[[1L]], method,
addl.data = list(data, weightitMSM.data, weightitMSM.data2))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["s.weights"]]),
data, weightitMSM.data, weightitMSM.data2)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, weightitMSM.data, weightitMSM.data2)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("treat.list", "covs.list", "addl.list", "distance.list"),
imp = imp,
original.call.to = "weightitMSM()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.default <- function(x, ...) {
if (!is.list(x)) {
.err("the input object must be an appropriate list, data.frame, formula, or the output of one of the supported packages")
}
if (...length() > 0L && (is_null(...names()) || !all(nzchar(...names())))) {
.err("all arguments to `...` must be named")
}
Q <- list(treat = list(name = c("treat", "tr"),
type = c("numeric", "character", "factor", "logical")),
treat.list = list(name = c("treat.list", "treat", "tr"),
type = c("list", "data.frame")),
covs = list(name = c("covs", "covariates", "x"),
type = c("data.frame")),
covs.list = list(name = c("covs.list", "covs", "covariates"),
type = c("list")),
formula = list(name = c("formula", "form"),
type = c("formula")),
formula.list = list(name = c("formula.list", "formula", "form"),
type = c("list")),
data = list(name = c("data"),
type = c("data.frame", "mids")),
weights = list(name = c("weights", "w", "wts"),
type = c("data.frame", "matrix", "numeric")),
distance = list(name = c("distance", "distance.list", "ps", "pscore", "p.score", "propensity.score"),
type = c("data.frame", "matrix", "numeric", "list")),
subclass = list(name = c("subclass", "strata"),
type = c("factor", "character", "numeric")),
match.strata = list(name = c("match.strata"),
type = c("factor", "character", "numeric")),
estimand = list(name = c("estimand", "target", "att", "ate"),
type = c("character", "numeric", "logical")),
s.weights = list(name = c("s.weights", "sw", "sweights", "sampw"),
type = c("numeric")),
focal = list(name = c("focal", "treatATT"),
type = c("character", "numeric")),
call = list(name = c("call"),
type = c("call")))
P <- make_list(names(Q))
names(x) <- tolower(names(x))
#Make a new list, P, containing the extracted components of obj; P acts as
#new object for future steps.
for (i in setdiff(names(Q), ...names())) {
for (j in Q[[i]][["name"]]) {
if (is_null(P[[i]]) && is_not_null(x[[j]])) {
which.type <- vapply(Q[[i]][["type"]], function(z) is_(x[[j]], z), logical(1L))
if (any(which.type)) {
P[[i]] <- x[[j]]
attr(P[[i]], "name") <- j
attr(P[[i]], "type") <- Q[[i]][["type"]][which.type]
}
}
}
}
#treat OK
#treat.list
if (is_not_null(P[["treat.list"]]) &&
!all_apply(P[["treat.list"]], function(z) any_apply(Q[["treat"]][["type"]],
function(c) is_(z, c)))) {
P[["treat.list"]] <- NULL
}
#covs
if (is_not_null(P[["covs"]])) {
P[["covs"]] <- as.data.frame(P[["covs"]])
}
#covs.list
if (is_not_null(P[["covs.list"]]) &&
!all_apply(P[["covs.list"]], function(z) any_apply(Q[["covs"]][["type"]],
function(c) is_(z, c)))) {
P[["covs.list"]] <- NULL
}
#formula
#formula.list
if (is_not_null(P[["formula.list"]]) &&
!all_apply(P[["formula.list"]], function(z) any_apply(Q[["formula"]][["type"]],
function(c) is_(z, c)))) {
P[["formula.list"]] <- NULL
}
#data
#model (only to extract data)
if (is_null(P[["data"]]) && is_not_null(x[["model"]]) && utils::hasName(x[["model"]], "data")) {
P[["data"]] <- x[["model"]][["data"]]
}
#weights
#distance
if (is_not_null(P[["distance"]])) {
if (is.list(P[["distance"]]) && !is.data.frame(P[["distance"]])) {
if (!all_apply(P[["distance"]], function(z) any_apply(Q[["distance"]][["type"]],
function(c) is_(z, c)))) {
P[["distance"]] <- NULL
}
}
else if (is.numeric(P[["distance"]])) {
P[["distance"]] <- setNames(data.frame(P[["distance"]]),
if_null_then(attr(P[["distance"]], "name", TRUE), "distance"))
}
else {
P[["distance"]] <- as.data.frame(P[["distance"]])
}
}
#distance.list
if (is_not_null(P[["distance.list"]]) &&
!all_apply(P[["distance.list"]], function(z) any_apply(Q[["distance"]][["type"]],
function(c) is_(z, c)))) {
P[["distance.list"]] <- NULL
}
#subclass
if (is_not_null(P[["subclass"]])) {
P[["subclass"]] <- factor(P[["subclass"]])
}
#match.strata
if (is_not_null(P[["match.strata"]])) {
P[["match.strata"]] <- factor(P[["match.strata"]])
}
#estimand
if (is_not_null(P[["estimand"]])) {
estimand.name <- attr(P[["estimand"]], "name", TRUE)
P[["estimand"]] <- {
if (is_not_null(estimand.name) && toupper(estimand.name) == "ATT") {
if (as.numeric(P[["estimand"]]) == 0) "ATE" else "ATT"
}
else if (is_not_null(estimand.name) && toupper(estimand.name) == "ATE") {
if (as.numeric(P[["estimand"]]) == 0) "ATT" else "ATE"
}
else if (tolower(P[["estimand"]]) %in% c("att", "treat", "treated", "tr", "t", "atet")) {
"ATT"
}
else if (tolower(P[["estimand"]]) %in% c("ate", "all")) {
"ATE"
}
else if (tolower(P[["estimand"]]) %in% c("atc", "control", "untreated", "u", "c", "ctrl", "atu", "atec", "ateu")) {
"ATC"
}
else {
NULL
}
}
}
#s.weights
#focal
#call
msm <- is_not_null(P[["treat.list"]]) || is_not_null(P[["formula.list"]])
if (msm) {
.x2base_default_msm(P, ...)
}
else {
.x2base_default_point(P, ...)
}
}
.x2base_default_point <- function(obj, ...) {
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
o.data <- obj[["data"]]
if (is_null(o.data) && is_not_null(obj[["model"]]) && utils::hasName(obj[["model"]], "data")) {
o.data <- obj[["model"]][["data"]]
}
if (inherits(o.data, "mids")) {
o.data <- .mids_complete(o.data)
}
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, o.data)
#Process treat
treat <- ...get("treat")
if (is_null(treat)) {
formula <- ...get("formula")
if (is_not_null(formula) && rlang::is_formula(formula, lhs = TRUE)) {
treat <- get_treat_from_formula(formula, data = if_null_then(data, o.data))
}
else if (is_not_null(obj[["treat"]])) {
treat <- obj[["treat"]]
}
else {
formula.obj <- obj[["formula"]]
if (is_not_null(formula.obj) && rlang::is_formula(formula.obj, lhs = TRUE)) {
treat <- get_treat_from_formula(formula.obj, data = if_null_then(data, o.data))
}
}
}
treat <- process_treat(treat, data, o.data)
#Process covs
covs <- ...get("covs")
if (is_null(covs)) {
formula <- ...get("formula")
if (is_not_null(formula) && rlang::is_formula(formula)) {
covs <- get_covs_from_formula(formula, data = if_null_then(data, o.data))
}
else if (is_not_null(obj[["covs"]])) {
covs <- obj[["covs"]]
}
else {
formula.obj <- obj[["formula"]]
if (is_not_null(formula.obj) && rlang::is_formula(formula.obj)) {
covs <- get_covs_from_formula(formula.obj, data = if_null_then(data, o.data))
}
}
}
if (is_null(covs)) {
.err("`covs` data.frame must be specified")
}
if (is_null(attr(covs, "co.names", TRUE))) {
if (is.matrix(covs)) covs <- as.data.frame.matrix(covs)
covs <- get_covs_from_formula(data = covs)
}
#Get estimand
estimand <- ...get("estimand", obj[["estimand"]])
#Get method
specified <- setNames(rep.int(FALSE, 3L), c("match.strata", "subclass", "weights"))
for (i in names(specified)) {
specified[i] <- is_not_null(...get(i, obj[[i]]))
}
.specified_method <- character()
.specified_args <- character()
.assuming <- character()
.ignoring <- character()
.not_present <- character()
.using <- character()
method <- ...get("method")
if (is_null(method)) {
if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.assuming <- method
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else {
method <- "matching"
}
}
else {
.specified_method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
if (length(method) == 1L) {
if (.specified_method == "weighting") {
if (specified["weights"]) {
method <- "weighting"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "weights"
}
else {
method <- "matching"
}
}
else if (.specified_method == "matching") {
if (specified["match.strata"]) {
method <- "matching"
.using <- "match.strata"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["weights"]) {
method <- "matching"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
.not_present <- c("weights", "match.strata")
.assuming <- method
}
else {
method <- "matching"
}
}
else if (.specified_method == "subclassification") {
if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "subclass"
}
else {
method <- "matching"
}
}
}
else {
if (specified["subclass"] || any(.specified_method == "subclassification")) {
.err("subclassification cannot be specified along with other methods")
}
if (specified["match.strata"]) {
.err("only weights can be specified with multiple methods")
}
if (specified["weights"]) {
method <- .specified_method
.using <- "weights"
}
else {
.wrn("multiple methods were specified, but no weights were provided. Providing unadjusted data only")
method <- "matching"
}
}
}
.m <- NULL
if (is_not_null(.using)) {
if (is_not_null(.specified_args) && is_not_null(.ignoring)) {
if (is_not_null(.assuming)) {
.m <- sprintf("%s specified. Assuming %s and using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
else {
.m <- sprintf("%s specified. Using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
}
else if (is_not_null(.specified_method) && is_not_null(.not_present) && is_not_null(.assuming)) {
.m <- sprintf("`method = %s` is specified, but %s was not supplied. Assuming %s and using %s instead",
add_quotes(.specified_method, 2L),
add_quotes(.not_present, "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"))
}
}
if (is_not_null(.m)) {
.msg(.m)
}
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, o.data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, o.data, covs),
obj.distance = obj[["distance"]],
obj.distance.name = attr(obj[["distance"]], "name", TRUE))
#Process focal
focal <- process_focal(...get("focal", obj[["focal"]]), treat)
if (get.treat.type(treat) == "binary") {
if (is_null(focal) && is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if ("subclass" %in% .using) {
subclass <- .process_vector(...get("subclass", obj[["subclass"]]),
datalist = list(data, o.data),
name = "subclass",
which = "subclass membership",
missing.okay = TRUE) |>
factor()
weights <- NULL
}
#Process match.strata
if ("match.strata" %in% .using) {
match.strata <- .process_vector(...get("match.strata", obj[["match.strata"]]),
datalist = list(data, o.data),
name = "match.strata",
which = "matching strata membership",
missing.okay = TRUE)
weights <- data.frame(weights = strata2weights(match.strata,
treat = treat,
estimand = estimand,
focal = focal))
}
#Process weights
if ("weights" %in% .using) {
weights <- process_weights(obj, list(...), treat, covs, method, addl.data = list(data, o.data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", obj[["s.weights"]]), data, o.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, o.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- ...get("discarded", obj[["discarded"]])
#Process length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
.x2base_default_msm <- function(obj, ...) {
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
o.data <- obj[["data"]]
if (is_null(o.data) && is_not_null(obj[["model"]]) && utils::hasName(obj[["model"]], "data")) {
o.data <- obj[["model"]][["data"]]
}
if (inherits(o.data, "mids")) {
o.data <- .mids_complete(o.data)
}
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, o.data)
#Process treat.list
treat.list <- process_treat.list(...get("treat.list"), data)
treat.list <- ...get("treat.list")
if (is_null(treat.list)) {
formula.list <- ...get("formula.list")
if (is_not_null(formula.list) && all_apply(formula.list, rlang::is_formula, lhs = TRUE)) {
treat.list <- make_list(length(formula.list))
for (i in seq_along(formula.list)) {
treat.list[[i]] <- get_treat_from_formula(formula.list[[i]], data = if_null_then(data, o.data))
names(treat.list)[i] <- attr(treat.list[[i]], "treat.name")
}
}
else if (is_not_null(obj[["treat.list"]])) {
treat.list <- obj[["treat.list"]]
}
else {
formula.list.obj <- obj[["formula.list.obj"]]
if (is_not_null(formula.list.obj) && all_apply(formula.list.obj, rlang::is_formula, lhs = TRUE)) {
treat.list <- make_list(length(formula.list.obj))
for (i in seq_along(formula.list.obj)) {
treat.list[[i]] <- get_treat_from_formula(formula.list.obj[[i]], data = if_null_then(data, o.data))
names(treat.list)[i] <- attr(treat.list[[i]], "treat.name")
}
}
}
}
treat.list <- process_treat.list(treat.list, data, o.data)
#Process covs.list
covs.list <- ...get("covs.list")
if (is_null(covs.list)) {
formula.list <- ...get("formula.list")
if (is_not_null(formula.list) && all_apply(formula.list, rlang::is_formula)) {
covs.list <- make_list(length(formula.list))
for (i in seq_along(formula.list)) {
covs.list[[i]] <- get_covs_from_formula(formula.list[[i]], data = if_null_then(data, o.data))
}
}
else if (is_not_null(obj[["covs.list"]])) {
covs.list <- obj[["covs.list"]]
}
else {
formula.list.obj <- obj[["formula.list.obj"]]
if (is_not_null(formula.list.obj) && all_apply(formula.list.obj, rlang::is_formula)) {
covs.list <- make_list(length(formula.list.obj))
for (i in seq_along(formula.list.obj)) {
covs.list[[i]] <- get_covs_from_formula(formula.list.obj[[i]], data = if_null_then(data, o.data))
}
}
}
}
if (is_null(covs.list)) {
.err("`covs.list` must be specified")
}
if (!is.list(covs.list) || is.data.frame(covs.list)) {
.err("`covs.list` must be a list of covariates for which balance is to be assessed at each time point")
}
if (!all_apply(covs.list, is_mat_like)) {
.err("each item in `covs.list` must be a data frame")
}
if (any_apply(covs.list, function(z) is_null(attr(z, "co.names")))) {
covs.list <- lapply(covs.list, function(z) get_covs_from_formula(data = z))
}
if (length(treat.list) != length(covs.list)) {
.err("`treat.list` must be a list of treatment statuses at each time point")
}
#Get estimand
estimand <- "ATE"
#Get method
specified <- setNames(rep.int(FALSE, 1L), "weights")
for (i in names(specified)) {
specified[i] <- is_not_null(...get(i, obj[[i]]))
}
.using <- character()
method <- ...get("method")
if (is_null(method)) {
method <- if (specified["weights"]) "weighting" else "matching"
if (any(specified)) {
.using <- names(specified)[specified][1L]
}
}
else {
specified.method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
method <- if (specified["weights"]) "weighting" else "matching"
if (any(specified)) {
.using <- names(specified)[specified][1L]
}
if (any(specified.method == "subclassification")) {
if (specified["weights"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
}
else {
.wrn("only weighting is allowed with multiple treatment time points. Providing unadjusted data only")
}
}
}
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, o.data),
covs.list = covs.list)
#Process distance
distance.list <- process_distance.list(...get("distance.list", ...get("distance", obj[["distance.list"]])),
datalist = list(data, o.data),
covs.list = covs.list)
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with longitudinal treatments")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with longitudinal treatments")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with longitudinal treatments")
}
#Process weights
if ("weights" %in% .using) {
weights <- process_weights(obj, list(...), treat.list[[1L]], covs.list[[1L]],
method, addl.data = list(data, o.data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", obj[["s.weights"]]),
data, o.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, o.data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("msm")
}
Try the cobalt package in your browser
Any scripts or data that you put into this service are public.
cobalt documentation built on April 16, 2025, 1:09 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .x2base_default_msm .x2base_default_point x2base.default x2base.weightitMSM x2base.CBMSM x2base.formula.list x2base.data.frame.list x2base.iptw x2base.sbwcau x2base.wimids x2base.mimids x2base.designmatch x2base.weightit x2base.cem.match x2base.optmatch x2base.ebalance x2base.CBPS x2base.data.frame x2base.formula x2base.Match x2base.ps.cont x2base.mnps x2base.ps x2base.matchit x2base
#Functions to convert object to base.bal.tab input
x2base <- function(x, ...) {
UseMethod("x2base")
}
#' @exportS3Method NULL
x2base.matchit <- function(x, ...) {
#Process matchit
#Process data and get imp
m.data <- if (NROW(x[["model"]][["data"]]) == length(x[["treat"]])) x[["model"]][["data"]] else NULL
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, m.data)
#Process treat
treat <- process_treat(x[["treat"]], data, m.data)
#Process covs
if (is.data.frame(x[["X"]])) {
covs <- get_covs_from_formula(data = x[["X"]])
}
else if (is_not_null(x[["model"]][["model"]])) {
if (nrow(x[["model"]][["model"]]) == length(treat)) {
covs <- get_covs_from_formula(x[["formula"]], data = x[["model"]][["model"]])
}
else {
#Recreating covs from model object and x[["X"]]. Have to do this because when
#discard != NULL and reestimate = TRUE, cases are lost. This recovers them.
# if (is_not_null(data)) {
# covs <- get_covs_from_formula(x[["formula"]], data = x[["model"]][["model"]])
# }
# else {
order <- setNames(attr(x[["model"]][["terms"]], "order"),
attr(x[["model"]][["terms"]], "term.labels"))
assign <- setNames(attr(x[["X"]], "assign"), colnames(x[["X"]]))
assign1 <- assign[assign %in% which(order == 1)] #Just main effects
dataClasses <- attr(x[["model"]][["terms"]], "dataClasses")
factors.to.unsplit <- names(dataClasses)[dataClasses %in% c("factor", "character", "logical")]
f0 <- setNames(lapply(factors.to.unsplit,
function(z) {
if (dataClasses[z] == "factor")
list(levels = levels(x[["model"]][["model"]][[z]]),
faclev = paste0(z, levels(x[["model"]][["model"]][[z]])))
else
list(levels = unique(x[["model"]][["model"]][[z]]),
faclev = paste0(z, unique(x[["model"]][["model"]][[z]])))
}),
factors.to.unsplit)
covs <- as.data.frame(x[["X"]][, names(assign1)])
for (i in factors.to.unsplit) {
covs <- unsplitfactor(covs, i, sep = "",
dropped.level = f0[[i]][["levels"]][f0[[i]][["faclev"]] %nin% colnames(x[["X"]])])
if (dataClasses[i] == "logical") {
covs[[i]] <- as.logical(covs[[i]])
}
}
covs <- get_covs_from_formula(x[["formula"]], data = covs)
# }
}
}
else if (is_not_null(x[["formula"]]) && is_not_null(data)) {
covs <- get_covs_from_formula(x[["formula"]], data = data)
}
else {
covs <- get_covs_from_formula(data = x[["X"]])
}
#Get estimand
estimand <- ...get("estimand", x[["estimand"]])
#Get method
if (inherits(x, "matchit.subclass")) {
method <- ...get("method")
method <- {
if (is_null(method) || !chk::vld_string(method)) "subclassification"
else match_arg(method, c("weighting", "subclassification"))
}
}
else {
method <- "matching"
}
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, m.data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, m.data, covs),
obj.distance = x[["distance"]],
obj.distance.name = "distance")
#Process focal
focal <- x[["focal"]]
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with matchit objects")
}
subclass <- switch(method,
"subclassification" = as.factor(x[["subclass"]]),
NULL)
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with matchit objects")
}
#Process weights
if (is_not_null(x[["weights"]]) && !all_the_same(x[["weights"]])) {
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, m.data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["s.weights"]]),
data, m.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, m.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- x[["discarded"]]
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "matchit()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.ps <- function(x, ...) {
#Process ps
stop.method <- ...get("stop.method")
if (is_null(stop.method) && ...length() > 0L && !nzchar(...names()[1L])) {
stop.method <- ...elt(1L)
}
if (is_null(stop.method) && is_not_null(...get("full.stop.method"))) {
stop.method <- ...get("full.stop.method")
}
available.stop.methods <- names(x[["w"]])
if (is_null(stop.method)) {
rule1 <- available.stop.methods
}
else if (is.character(stop.method)) {
rule1 <- available.stop.methods[vapply(tolower(available.stop.methods),
function(z) any(startsWith(z, tolower(stop.method))), logical(1L))]
if (is_null(rule1)) {
.wrn(sprintf("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L)))
rule1 <- available.stop.methods
}
}
else if (is.numeric(stop.method) && any(stop.method %in% seq_along(available.stop.methods))) {
if (!all(stop.method %in% seq_along(available.stop.methods))) {
.wrn(sprintf("there are %s stop methods available, but you requested %s",
length(available.stop.methods),
word_list(setdiff(stop.method, seq_along(available.stop.methods)), and.or = "and")))
}
rule1 <- available.stop.methods[stop.method %in% seq_along(available.stop.methods)]
}
else {
.wrn("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L))
rule1 <- available.stop.methods
}
s <- available.stop.methods[match(tolower(rule1), tolower(available.stop.methods))]
#Process data and get imp
ps.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, ps.data)
#Process treat
treat <- process_treat(x[["treat"]], data, ps.data)
#Process covs
if (is_not_null(x[["gbm.obj"]][["var.names"]])) {
covs <- reformulate(x[["gbm.obj"]][["var.names"]]) |>
get_covs_from_formula(data = ps.data)
}
else if (is_not_null(...get("formula")) || is_not_null(...get("covs"))) {
t.c <- .use_tc_fd(formula = ...get("formula"),
data = if_null_then(data, ps.data),
covs = ...get("covs"),
needs.treat = FALSE)
#Process covs
covs <- t.c[["covs"]]
}
else if (all(x[["gbm.obj"]][["feature_names"]] %in% names(ps.data))) {
covs <- reformulate(x[["gbm.obj"]][["feature_names"]]) |>
get_covs_from_formula(data = ps.data)
}
else {
.err('when `version = "xgboost"` in the call to `ps()` and any variables are categorical, `formula` or `covs` must be supplied')
}
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- rep.int("weighting", length(s))
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, ps.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, ps.data, covs),
obj.distance = x[["ps"]][s],
obj.distance.name = {
if (length(s) > 1L) paste.("prop.score", substr(s, 1L, nchar(s) - 4L))
else "prop.score"
})
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with ps objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with ps objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with ps objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, ps.data),
stop.method = s, estimand = estimand)
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["sampw"]]),
data, ps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, ps.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "ps()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
# call <- ps[["parameters"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.mnps <- function(x, ...) {
#Process mnps
stop.method <- ...get("stop.method")
if (is_null(stop.method) && ...length() > 0L && !nzchar(...names()[1L])) {
stop.method <- ...elt(1L)
}
if (is_null(stop.method) && is_not_null(...get("full.stop.method"))) {
stop.method <- ...get("full.stop.method")
}
available.stop.methods <- x[["stopMethods"]]
if (is_null(stop.method)) {
rule1 <- available.stop.methods
}
else if (is.character(stop.method)) {
rule1 <- available.stop.methods[vapply(tolower(available.stop.methods),
function(z) any(startsWith(z, tolower(stop.method))), logical(1L))]
if (is_null(rule1)) {
.wrn(sprintf("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L)))
rule1 <- available.stop.methods
}
}
else if (is.numeric(stop.method) && any(stop.method %in% seq_along(available.stop.methods))) {
if (!all(stop.method %in% seq_along(available.stop.methods))) {
.wrn(sprintf("there are %s stop methods available, but you requested %s",
length(available.stop.methods),
word_list(setdiff(stop.method, seq_along(available.stop.methods)), and.or = "and")))
}
rule1 <- available.stop.methods[stop.method %in% seq_along(available.stop.methods)]
}
else {
.wrn("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2))
rule1 <- available.stop.methods
}
s <- available.stop.methods[match(tolower(rule1), tolower(available.stop.methods))]
#Process data and get imp
mnps.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, mnps.data)
#Process treat
treat <- process_treat(x[["treatVar"]], data, mnps.data)
#Process covs
.v <- if_null_then(x[["balanceVars"]],
x[["psList"]][[1L]][["gbm.obj"]][["var.names"]])
covs <- get_covs_from_formula(reformulate(.v), mnps.data)
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- rep.int("weighting", length(s))
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, mnps.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, mnps.data))
#Process focal
focal <- x[["treatATT"]]
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with mnps objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with mnps objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, mnps.data),
stop.method = s)
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["sampw"]]),
data, mnps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, mnps.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "mnps()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("multi")
}
#' @exportS3Method NULL
x2base.ps.cont <- function(x, ...) {
#Process data and get imp
ps.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, ps.data)
#Process treat
treat <- process_treat(x[["treat"]], data, ps.data)
#Process covs
covs <- reformulate(x[["gbm.obj"]][["var.names"]]) |>
get_covs_from_formula(ps.data)
#Get estimand
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, ps.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, ps.data))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with ps.cont objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with ps.cont objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with ps.cont objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, ps.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["sampw"]]),
data, ps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, ps.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "ps.cont()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
# call <- ps.cont[["parameters"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("cont")
}
#' @exportS3Method NULL
x2base.Match <- function(x, ...) {
#Process Match
if (is_not_null(x) && !is.list(x)) {
.err("the supplied Match object contains no valid matches")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data, ...get("treat"), ...get("covs"))
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with Match objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with Match objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with Match objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- rep.int(FALSE, length(treat))
if (is_not_null(x[["index.dropped"]])) {
discarded[x[["index.dropped"]]] <- TRUE
}
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "Match()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.formula <- function(x, ...) {
x2base.data.frame(x = x, ...)
}
#' @exportS3Method NULL
x2base.data.frame <- function(x, ...) {
#Process data.frame
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
treat <- {
if (rlang::is_formula(x))
get_treat_from_formula(x, data, treat = ...get("treat"))
else
...get("treat")
}
treat <- process_treat(treat, data)
#Process covs
covs <- x
if (is.null(covs)) {
.err("`covs` data.frame must be specified")
}
if (rlang::is_formula(covs)) {
covs <- get_covs_from_formula(covs, data = data)
# if (is_null(covs)) {
# .err("The right hand side of the formula must contain covariates for which balance is to be assessed")
# }
}
if (is_null(attr(covs, "co.names"))) {
if (is.matrix(covs)) covs <- as.data.frame.matrix(covs)
covs <- get_covs_from_formula(data = covs)
}
#Get estimand
estimand <- ...get("estimand")
#Get method
specified <- setNames(rep.int(FALSE, 3L), c("match.strata", "subclass", "weights"))
for (i in names(specified)) {
specified[i] <- is_not_null(...get(i))
}
.specified_method <- character()
.specified_args <- character()
.assuming <- character()
.ignoring <- character()
.not_present <- character()
.using <- character()
method <- ...get("method")
if (is_null(method)) {
if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.assuming <- method
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else {
method <- "weighting"
}
}
else {
.specified_method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
if (length(method) == 1L) {
if (.specified_method == "weighting") {
if (specified["weights"]) {
method <- "weighting"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "weights"
}
else {
method <- "matching"
}
}
else if (.specified_method == "matching") {
if (specified["match.strata"]) {
method <- "matching"
.using <- "match.strata"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["weights"]) {
method <- "matching"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
.not_present <- c("weights", "match.strata")
.assuming <- method
}
else {
method <- "matching"
}
}
else if (.specified_method == "subclassification") {
if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "subclass"
}
else {
method <- "matching"
}
}
}
else {
if (specified["subclass"] || any(.specified_method == "subclassification")) {
.err("subclassification cannot be specified along with other methods")
}
if (specified["match.strata"]) {
.err("only weights can be specified with multiple methods")
}
if (specified["weights"]) {
method <- .specified_method
.using <- "weights"
}
else {
.wrn("multiple methods were specified, but no weights were provided. Providing unadjusted data only")
method <- "matching"
}
}
}
.m <- NULL
if (is_not_null(.using)) {
if (is_not_null(.specified_args) && is_not_null(.ignoring)) {
if (is_not_null(.assuming)) {
.m <- sprintf("%s specified. Assuming %s and using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
else {
.m <- sprintf("%s specified. Using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
}
else if (is_not_null(.specified_method) && is_not_null(.not_present) && is_not_null(.assuming)) {
.m <- sprintf("`method = %s` is specified, but %s was not supplied. Assuming %s and using %s instead",
add_quotes(.specified_method, 2L),
add_quotes(.not_present, "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"))
}
}
if (is_not_null(.m)) {
.msg(.m)
}
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- process_focal(...get("focal"), treat)
if (get.treat.type(treat) == "binary") {
if (is_null(focal) && is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if ("subclass" %in% .using) {
subclass <- .process_vector(...get("subclass"),
datalist = list(data),
name = "subclass",
which = "subclass membership",
missing.okay = TRUE) |>
factor()
weights <- NULL
}
#Process match.strata
if ("match.strata" %in% .using) {
match.strata <- .process_vector(...get("match.strata"),
datalist = list(data),
name = "match.strata",
which = "matching strata membership",
missing.okay = TRUE)
weights <- data.frame(weights = strata2weights(match.strata,
treat = treat,
estimand = estimand,
focal = focal))
}
#Process weights
if ("weights" %in% .using) {
weights <- process_weights(NULL, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- ...get("discarded")
#Process length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.CBPS <- function(x, ...) {
#Process CBPS
#Process data and get imp
c.data <- x[["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, c.data)
#Process treat
treat <- get_treat_from_formula(x[["formula"]], c.data) |>
process_treat(data, c.data)
#Process covs
covs <- get_covs_from_formula(x[["formula"]], c.data)
#Get estimand
estimand <- ...get("estimand")
if (is_not_null(estimand)) {
.err("`estimand` is not allowed with CBPS objects")
}
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, c.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, c.data),
obj.distance = if (get.treat.type(treat) == "binary") x[["fitted.values"]],
obj.distance.name = "prop.score")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with CBPS objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with CBPS objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with CBPS objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, c.data),
use.weights = ...get("use.weights"))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"),
data, c.data)
if (is_not_null(s.weights)) {
weights <- weights / s.weights #Because CBPS weights contain s.weights in them
}
#Process cluster
cluster <- process_cluster(...get("cluster"), data, c.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "CBPS()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.ebalance <- function(x, ...) {
#Process ebalance
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data, ...get("treat"), ...get("covs"))
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- "ATT"
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with ebalance objects")
}
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with ebalance objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with ebalance objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "ebalance()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) stats <- unique(c(stats, names(thresholds)))
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.optmatch <- function(x, ...) {
#Process optmatch
if (all(is.na(x))) {
.err("the supplied optmatch abject contains no valid matches")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data = data, covs = ...get("covs"),
treat = ...get("treat", as.numeric(attr(x, "contrast.group"))))
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- ...get("estimand", "ATT")
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with optmatch objects")
}
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with optmatch objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with optmatch objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = sprintf("%s()", deparse1(attr(x, "call")[[1L]])))
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- attr(x, "call")
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.cem.match <- function(x, ...) {
#Process cem.match
if (inherits(x, "cem.match.list")) {
x[["vars"]] <- x[[1L]][["vars"]]
x[["baseline.group"]] <- x[[1L]][["baseline.group"]]
x[["groups"]] <- unlist(grab(x[vapply(x, inherits, logical(1L), "cem.match")], "groups"))
x[["w"]] <- get.w.cem.match(x)
}
if (all(check_if_zero(x[["w"]]))) {
.err("the supplied cem.match object contains no valid matches")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
if (is_null(data)) {
.err("an argument to `data` must be specified with cem.match objects")
}
#Process imp
imp <- process_imp(imp, data)
if (is_null(imp) && inherits(x, "cem.match.list") &&
sum(vapply(x, is_, logical(1L), "cem.match")) != 1L) {
.err("an argument to `imp` must be specified or the argument to data must be a mids object")
}
#Process treat
t.c <- .use_tc_fd(data = data, treat = x[["groups"]],
covs = x[["vars"]])
treat <- process_treat(t.c[["treat"]], data)
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- ...get("estimand")
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with cem.match objects")
}
#Process focal
focal <- x[["baseline.group"]]
#Process pairwise
if (get.treat.type(treat) == "binary" && is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with cem.match objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "cem()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.weightit <- function(x, ...) {
#Process weightit
#Process data and get imp
d.e.in.w <- vapply(c("covs", "exact", "by", "moderator"), function(z) is_not_null(x[[z]]), logical(1L))
if (any(d.e.in.w)) weightit.data <- do.call("data.frame", unname(x[c("covs", "exact", "by", "moderator")[d.e.in.w]]))
else weightit.data <- NULL
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, weightit.data)
#Process treat
treat <- process_treat(x[["treat"]], data, weightit.data)
#Process covs
covs <- x[["covs"]]
if (is_not_null(covs)) {
covs <- get_covs_from_formula(data = covs)
}
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, weightit.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, weightit.data),
obj.distance = if (get.treat.type(treat) == "binary") x[["ps"]],
obj.distance.name = "prop.score")
#Process focal
focal <- x[["focal"]]
#Process pairwise
if (get.treat.type(treat) == "binary" && is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with weightit objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with weightit objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, weightit.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["s.weights"]]),
data, weightit.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, weightit.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- x[["discarded"]]
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "weightit()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.designmatch <- function(x, ...) {
#Process designmatch
if (all(c("id_1", "id_2") %in% names(x))) {
.err("Balance cannot currently be checked on a nonbipartite match")
}
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat
t.c <- .use_tc_fd(...get("formula"), data, ...get("treat"), ...get("covs"))
treat <- process_treat(t.c[["treat"]], data)
if (is.unsorted(rev(treat))) {
.wrn("designmatch requires the input data to be sorted by treatment; the data supplied to `bal.tab()` was not, indicating a possible coding error")
}
#Process covs
covs <- t.c[["covs"]]
#Get estimand
estimand <- ...get("estimand")
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, covs))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with designmatch objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with designmatch objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with designmatch objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "the matching function in designmatch")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#' @exportS3Method NULL
x2base.mimids <- function(x, ...) {
#Process mimids
old_version <- !all(c("object", "models", "approach") %in% names(x))
models <- if (old_version) x[["models"]][-1L] else x[["models"]]
#Process data and get imp
m.data <- {
if (!old_version) .mids_complete(x[["object"]])
else if (inherits(x[["original.datasets"]], "mids")) .mids_complete(x[["original.datasets"]])
else .mids_complete(x[["others"]][["source"]])
}
imp <- m.data[[".imp"]]
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
# .wrn("The argument to data is not a data.frame and will be ignored. If the argument to treat is not a vector, the execution will halt")
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, m.data)
#Process treat
treat <- process_treat(unlist(grab(models, "treat")))
#Process covs
covs <- do.call("rbind", grab(models, "X"))
covs <- get_covs_from_formula(data = covs)
#Get estimand
estimand <- models[[1L]][["estimand"]]
#Get method
method <- "matching"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, m.data))
#Process distance
m.distance <- unlist(grab(models, "distance"))
if (all(is.na(m.distance))) m.distance <- NULL
distance <- process_distance(...get("distance"), datalist = list(data, m.data),
obj.distance = m.distance,
obj.distance.name = "distance")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with mimids objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with mimids objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with mimids objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, m.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", unlist(grab(models, "s.weights"))),
data, m.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, m.data)
#Process subset
subset <- process_subset(...get("subset"), min(table(imp)))
#Process discarded
discarded <- unlist(grab(models, "discarded"))
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "matchthem()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("imp")
}
#' @exportS3Method NULL
x2base.wimids <- function(x, ...) {
#Process wimids
old_version <- !all(c("object", "models", "approach") %in% names(x))
models <- if (old_version) x[["models"]][-1L] else x[["models"]]
#Process data and get imp
w.data <- {
if (!old_version) .mids_complete(x[["object"]])
else if (inherits(x[["original.datasets"]], "mids")) .mids_complete(x[["original.datasets"]])
else .mids_complete(x[["others"]][["source"]])
}
imp <- w.data[[".imp"]]
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
# .wrn("The argument to data is not a data.frame and will be ignored. If the argument to treat is not a vector, the execution will halt")
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, w.data)
#Process treat
treat <- process_treat(unlist(grab(models, "treat")))
#Process covs
covs <- do.call("rbind", grab(models, "covs"))
covs <- get_covs_from_formula(data = covs)
#Get estimand
estimand <- unique(unlist(grab(models, "estimand")))
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, w.data))
#Process distance
w.distance <- unlist(grab(models, "ps"))
if (all(is.na(w.distance))) w.distance <- NULL
distance <- process_distance(...get("distance"), datalist = list(data, w.data),
obj.distance = if (get.treat.type(treat) == "binary") w.distance,
obj.distance.name = "prop.score")
#Process focal
focal <- unique(unlist(grab(models, "focal")))
#Process pairwise
if (get.treat.type(treat) == "binary" && is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with wimids objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with wimids objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, w.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", unlist(grab(models, "s.weights"))),
data, w.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, w.data)
#Process subset
subset <- process_subset(...get("subset"), min(table(imp)))
#Process discarded
discarded <- unlist(grab(models, "discarded"))
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "weightthem()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("imp")
}
#' @exportS3Method NULL
x2base.sbwcau <- function(x, ...) {
#Process sbwcau
#Process data and get imp
sbw.data <- x[["dat_weights"]][names(x[["dat_weights"]]) != "weights"]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, sbw.data)
#Process treat
treat <- process_treat(x[["ind"]], data, sbw.data)
#Process covs
covs <- reformulate(x[["bal"]][["bal_cov"]]) |>
get_covs_from_formula(data = sbw.data)
#Get estimand
estimand <- x[["par"]][["par_est"]]
#Get method
method <- "weighting"
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, sbw.data))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, sbw.data))
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with sbwcau objects")
}
if (get.treat.type(treat) == "binary") {
if (is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with sbwcau objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with sbwcau objects")
}
#Process weights
weights <- process_weights(x, list(...), treat, covs, method, addl.data = list(data, sbw.data))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data, sbw.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, sbw.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
#Process imp and length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp,
original.call.to = "sbw()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("binary")
}
#MSMs wth multiple time points
#' @exportS3Method NULL
x2base.iptw <- function(x, ...) {
#Process iptw
stop.method <- ...get("stop.method")
if (is_null(stop.method) && ...length() > 0L && !nzchar(...names()[1L])) {
stop.method <- ...elt(1L)
}
if (is_null(stop.method) && is_not_null(...get("full.stop.method"))) {
stop.method <- ...get("full.stop.method")
}
available.stop.methods <- names(x[["psList"]][[1L]][["ps"]])
if (is_null(stop.method)) {
rule1 <- available.stop.methods
}
else if (is.character(stop.method)) {
rule1 <- available.stop.methods[vapply(tolower(available.stop.methods),
function(z) any(startsWith(z, tolower(stop.method))), logical(1L))]
if (is_null(rule1)) {
.wrn(sprintf("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L)))
rule1 <- available.stop.methods
}
}
else if (is.numeric(stop.method) && any(stop.method %in% seq_along(available.stop.methods))) {
if (!all(stop.method %in% seq_along(available.stop.methods))) {
.wrn(sprintf("there are %s stop methods available, but you requested %s",
length(available.stop.methods),
word_list(setdiff(stop.method, seq_along(available.stop.methods)), and.or = "and")))
}
rule1 <- available.stop.methods[stop.method %in% seq_along(available.stop.methods)]
}
else {
.wrn("`stop.method` should be %s. Using all available stop methods instead",
word_list(available.stop.methods, and.or = "or", quotes = 2L))
rule1 <- available.stop.methods
}
s <- available.stop.methods[match(tolower(rule1), tolower(available.stop.methods))]
#Process data and get imp
ps.data <- x[["psList"]][[1L]][["data"]]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, ps.data)
#Process treat.list
treat.list <- process_treat.list(grab(x[["psList"]], "treat"), data, ps.data)
#Process covs.list
if (all_apply(x[["psList"]], function(z) is_not_null(z[["gbm.obj"]][["var.names"]]))) {
covs.list <- lapply(x[["psList"]], function(z) {
reformulate(z[["gbm.obj"]][["var.names"]]) |>
get_covs_from_formula(data = z[["data"]])
})
}
else if (is_not_null(...get("formula.list")) || is_not_null(...get("covs.list"))) {
covs.list <- ...get("covs.list")
if (is_not_null(covs.list)) {
if (!is.list(covs.list) || is.data.frame(covs.list)) {
.err("`covs.list` must be a list of covariates for which balance is to be assessed at each time point")
}
if (!all_apply(covs.list, is_mat_like)) {
.err("each item in `covs.list` must be a data frame")
}
if (length(covs.list) != length(x[["psList"]])) {
.err("`covs.list` must have as many entries as time points in the call to `iptw()`")
}
}
formula.list <- ...get("formula.list")
if (is_not_null(formula.list)) {
if (!is.list(formula.list) || !all_apply(formula.list, rlang::is_formula)) {
.err("`formula.list` must be a list of formulas identifying the covariates for which balance is to be assessed at each time point")
}
if (length(formula.list) != length(x[["psList"]])) {
.err("`formula.list` must have as many entries as time points in the call to `iptw()`")
}
}
covs.list <- lapply(seq_along(x[["psList"]]), function(i) {
.use_tc_fd(formula = formula.list[[i]],
data = if_null_then(data, x[["psList"]][[i]][["data"]]),
covs = covs.list[[i]],
needs.treat = FALSE)[["covs"]]
})
}
else if (all_apply(x[["psList"]], function(z) all(z[["gbm.obj"]][["feature_names"]] %in% names(z[["data"]])))) {
covs.list <- lapply(x[["psList"]], function(z) {
reformulate(z[["gbm.obj"]][["feature_names"]]) |>
get_covs_from_formula(data = z[["data"]])
})
}
else {
.err('when `version = "xgboost"` in the call to `iptw()` and any variables are categorical, `formula.list` or `covs.list` must be supplied')
}
#Get estimand
estimand <- substr(toupper(s), nchar(s) - 2L, nchar(s))
#Get method
method <- rep.int("weighting", length(s))
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, ps.data),
covs.list = covs.list)
#Process distance
# ntimes <- iptw[["nFits"]]
# distance.list <- .process_list("distance.list", ...get("distance.list"), ntimes,
# "the original call to iptw()",
# treat.list,
# covs.list,
# list(data, ps.data))
# if (is_not_null(distance.list)) {
# for (ti in seq_along(distance.list)) {
# if (length(s) == 1) {
# distance.list[[ti]] <- data.frame(distance[[ti]], prop.score = iptw[["psList"]][[ti]][["ps"]][[s]])
# }
# else {
# distance.list[[ti]] <- data.frame(distance[[ti]], prop.score = iptw[["psList"]][[ti]][["ps"]][s])
# }
# }
#
# }
# else {
# distance.list <- make_list(ntimes)
# for (ti in seq_along(distance.list)) {
# if (length(s) == 1) {
# distance.list[[ti]] <- data.frame(prop.score = iptw[["psList"]][[ti]][["ps"]][[s]])
# }
# else {
# distance.list[[ti]] <- data.frame(prop.score = iptw[["psList"]][[ti]][["ps"]][s])
# }
# }
# }
# if (is_not_null(distance.list)) distance.list <- lapply(distance.list, function(z) get_covs_from_formula(~z))
#
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data, ps.data),
covs.list = covs.list,
obj.distance = lapply(x[["psList"]], function(z) z[["ps"]][, s, drop = FALSE]),
obj.distance.name = {
if (length(s) > 1L) paste.("prop.score", substr(s, 1L, nchar(s) - 4L))
else "prop.score"
})
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with iptw objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with iptw objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with iptw objects")
}
#Process weights
weights <- process_weights(x, list(...), treat.list[[1L]], covs.list[[1L]],
method, addl.data = list(data, ps.data),
stop.method = s)
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["psList"]][[1L]][["sampw"]]),
data, ps.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, ps.data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp,
original.call.to = "iptw()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.data.frame.list <- function(x, ...) {
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat.list
treat.list <- process_treat.list(...get("treat.list"), data)
#Process covs.list
covs.list <- x
if (is_null(covs.list)) {
.err("`covs.list` must be specified")
}
if (!is.list(covs.list) || is.data.frame(covs.list)) {
.err("`covs.list` must be a list of covariates for which balance is to be assessed at each time point")
}
if (!all_apply(covs.list, is_mat_like)) {
.err("each item in `covs.list` must be a data frame")
}
if (any_apply(covs.list, function(z) is_null(attr(z, "co.names")))) {
covs.list <- lapply(covs.list, function(z) get_covs_from_formula(data = z))
}
if (length(treat.list) != length(covs.list)) {
.err("`treat.list` must be a list of treatment statuses at each time point")
}
#Get estimand
estimand <- "ATE"
#Get method
specified <- setNames(rep.int(FALSE, 1L), "weights")
if (is_not_null(...get("weights"))) {
if (!is_(...get("weights"), c("character", "numeric", "data.frame", "list"))) {
.err("the argument to `weights` must be a vector, list, or data frame of weights or the (quoted) names of variables in `data` that contain weights")
}
specified["weights"] <- TRUE
}
method <- ...get("method")
if (is_null(method)) {
method <- if (specified["weights"]) "weighting" else "matching"
}
else if (length(method) == 1L) {
specified.method <- match_arg(method, c("weighting", "matching", "subclassification"))
if (specified.method == "weighting") {
method <- if (specified["weights"]) "weighting" else "matching"
}
else if (specified["weights"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
method <- "weighting"
}
else {
method <- "matching"
}
}
else {
specified.method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
if (any(specified.method == "subclassification") || specified["subclass"] || specified["match.strata"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
method <- "weighting"
}
else if (specified["weights"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
method <- "weighting"
}
# else if (!specified["weights"]) {
# #Should never happen
# .wrn("multiple methods were specified, but no weights were provided. Providing unadjusted data only")
# method <- "matching"
# }
else {
method <- "matching"
}
}
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data),
covs.list = covs.list)
#Process distance
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data),
covs.list = covs.list)
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with longitudinal treatments")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with longitudinal treatments")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with longitudinal treatments")
}
#Process weights
weights <- ...get("weights")
if (is_not_null(weights)) {
weights <- process_weights(NULL, list(...), treat.list[[1L]], covs.list[[1L]],
method, addl.data = list(data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights"), data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("msm")
}
#' @exportS3Method NULL
x2base.formula.list <- function(x, ...) {
treat.list <- covs.list <- make_list(length(x))
for (i in seq_along(x)) {
treat.list[[i]] <- get_treat_from_formula(x[[i]], data = ...get("data"))
covs.list[[i]] <- get_covs_from_formula(x[[i]], data = ...get("data"))
names(treat.list)[i] <- attr(treat.list[[i]], "treat.name")
}
if ("treat.list" %in% ...names()) {
A <- list(...)
A[["x"]] <- covs.list
A[["treat.list"]] <- treat.list
return(do.call("x2base.data.frame.list", A))
}
x2base.data.frame.list(covs.list, treat.list = treat.list, ...)
}
#' @exportS3Method NULL
x2base.CBMSM <- function(x, ...) {
#Process CBMSM
ID <- sort(unique(x[["id"]]))
times <- sort(unique(x[["time"]]))
x[["data"]] <- x[["data"]][order(x[["id"]], x[["time"]]), ,drop = FALSE]
#Process data and get imp
cbmsm.data <- x[["data"]][x[["time"]] == 1, , drop = FALSE]
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data)
#Process treat.list
treat.list <- process_treat.list(lapply(times, function(z) x[["treat.hist"]][ID, z]),
data, cbmsm.data)
#Process covs.list
covs.list <- make_list(times)
for (i in seq_along(times)) {
ti <- times[i]
cov_i <- get_covs_from_formula(x[["formula"]], data = x[["data"]][x[["time"]] == ti, , drop = FALSE])
for (co in seq_along(attr(cov_i, "co.names"))) {
attr(cov_i, "co.names")[[co]][["component"]][attr(cov_i, "co.names")[[co]][["type"]] == "base"] <-
paste0(attr(cov_i, "co.names")[[co]][["component"]][attr(cov_i, "co.names")[[co]][["type"]] == "base"], "_T", ti)
}
names(attr(cov_i, "co.names")) <- vapply(attr(cov_i, "co.names"), function(z) paste(z[["component"]], collapse = ""), character(1L))
colnames(cov_i) <- names(attr(cov_i, "co.names"))
covs.list[[i]] <- {
if (i == 1L) cov_i
else co.cbind(covs.list[[i - 1L]], cov_i)
}
}
#Get estimand
estimand <- "ATE"
#Get method
method <- "weighting"
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, cbmsm.data),
covs.list = covs.list)
#Process distance
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data, cbmsm.data),
covs.list = covs.list, obj.distance = x[["fitted.values"]],
obj.distance.name = "prop.score")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with CBMSM objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with CBMSM objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with CBMSM objects")
}
#Process weights
weights <- process_weights(x, list(...), treat.list[[1L]], covs.list[[1L]], method,
addl.data = list(data, cbmsm.data))
method <- attr(weights, "method")
#Process s.weights
if (is_not_null(...get("s.weights"))) {
.err("sampling weights are not allowed with CBMSM objects")
}
#Process cluster
cluster <- process_cluster(...get("cluster"), data, cbmsm.data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp,
original.call.to = "CBMSM()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.weightitMSM <- function(x, ...) {
#Process weightitMSM
#Process data and get imp
weightitMSM.data <- x[["data"]]
d.e.in.w <- vapply(c("exact", "by", "moderator"), function(z) is_not_null(x[[z]]), logical(1L))
weightitMSM.data2 <- {
if (any(d.e.in.w)) do.call("data.frame", unname(x[c("exact", "by", "moderator")[d.e.in.w]]))
else NULL
}
imp <- ...get("imp")
data <- ...get("data")
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, weightitMSM.data, weightitMSM.data2)
#Process treat.list
treat.list <- process_treat.list(x[["treat.list"]],
data, weightitMSM.data, weightitMSM.data2)
#Process covs.list
covs.list <- lapply(x[["covs.list"]], function(z) get_covs_from_formula(data = z))
#Get estimand
estimand <- x[["estimand"]]
#Get method
method <- "weighting"
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, weightitMSM.data,
weightitMSM.data2),
covs.list = covs.list)
#Process distance
# ntimes <- length(covs.list)
# distance.list <- .process_list("distance.list", ...get("distance.list"), ntimes,
# "the original call to weightitMSM()",
# treat.list,
# covs.list,
# list(data, weightitMSM.data,
# weightitMSM.data2))
# if (is_not_null(distance.list)) distance.list <- lapply(seq_along(distance.list), function(z) data.frame(distance.list[[z]], prop.score = weightitMSM[["ps.list"]][[z]]))
# else if (is_not_null(weightitMSM[["ps.list"]])) distance.list <- lapply(seq_along(weightitMSM[["ps.list"]]), function(z) data.frame(prop.score = weightitMSM[["ps.list"]][[z]]))
# else distance.list <- NULL
# if (is_not_null(distance.list)) distance.list <- lapply(distance.list, function(z) get_covs_from_formula(~z))
distance.list <- process_distance.list(...get("distance.list", ...get("distance")),
datalist = list(data, weightitMSM.data, weightitMSM.data2),
covs.list = covs.list, obj.distance = x[["ps.list"]],
obj.distance.name = "prop.score")
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with weightitMSM objects")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with weightitMSM objects")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with weightitMSM objects")
}
#Process weights
weights <- process_weights(x, list(...), treat.list[[1L]], covs.list[[1L]], method,
addl.data = list(data, weightitMSM.data, weightitMSM.data2))
method <- attr(weights, "method")
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", x[["s.weights"]]),
data, weightitMSM.data, weightitMSM.data2)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, weightitMSM.data, weightitMSM.data2)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("treat.list", "covs.list", "addl.list", "distance.list"),
imp = imp,
original.call.to = "weightitMSM()")
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- x[["call"]]
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
#' @exportS3Method NULL
x2base.default <- function(x, ...) {
if (!is.list(x)) {
.err("the input object must be an appropriate list, data.frame, formula, or the output of one of the supported packages")
}
if (...length() > 0L && (is_null(...names()) || !all(nzchar(...names())))) {
.err("all arguments to `...` must be named")
}
Q <- list(treat = list(name = c("treat", "tr"),
type = c("numeric", "character", "factor", "logical")),
treat.list = list(name = c("treat.list", "treat", "tr"),
type = c("list", "data.frame")),
covs = list(name = c("covs", "covariates", "x"),
type = c("data.frame")),
covs.list = list(name = c("covs.list", "covs", "covariates"),
type = c("list")),
formula = list(name = c("formula", "form"),
type = c("formula")),
formula.list = list(name = c("formula.list", "formula", "form"),
type = c("list")),
data = list(name = c("data"),
type = c("data.frame", "mids")),
weights = list(name = c("weights", "w", "wts"),
type = c("data.frame", "matrix", "numeric")),
distance = list(name = c("distance", "distance.list", "ps", "pscore", "p.score", "propensity.score"),
type = c("data.frame", "matrix", "numeric", "list")),
subclass = list(name = c("subclass", "strata"),
type = c("factor", "character", "numeric")),
match.strata = list(name = c("match.strata"),
type = c("factor", "character", "numeric")),
estimand = list(name = c("estimand", "target", "att", "ate"),
type = c("character", "numeric", "logical")),
s.weights = list(name = c("s.weights", "sw", "sweights", "sampw"),
type = c("numeric")),
focal = list(name = c("focal", "treatATT"),
type = c("character", "numeric")),
call = list(name = c("call"),
type = c("call")))
P <- make_list(names(Q))
names(x) <- tolower(names(x))
#Make a new list, P, containing the extracted components of obj; P acts as
#new object for future steps.
for (i in setdiff(names(Q), ...names())) {
for (j in Q[[i]][["name"]]) {
if (is_null(P[[i]]) && is_not_null(x[[j]])) {
which.type <- vapply(Q[[i]][["type"]], function(z) is_(x[[j]], z), logical(1L))
if (any(which.type)) {
P[[i]] <- x[[j]]
attr(P[[i]], "name") <- j
attr(P[[i]], "type") <- Q[[i]][["type"]][which.type]
}
}
}
}
#treat OK
#treat.list
if (is_not_null(P[["treat.list"]]) &&
!all_apply(P[["treat.list"]], function(z) any_apply(Q[["treat"]][["type"]],
function(c) is_(z, c)))) {
P[["treat.list"]] <- NULL
}
#covs
if (is_not_null(P[["covs"]])) {
P[["covs"]] <- as.data.frame(P[["covs"]])
}
#covs.list
if (is_not_null(P[["covs.list"]]) &&
!all_apply(P[["covs.list"]], function(z) any_apply(Q[["covs"]][["type"]],
function(c) is_(z, c)))) {
P[["covs.list"]] <- NULL
}
#formula
#formula.list
if (is_not_null(P[["formula.list"]]) &&
!all_apply(P[["formula.list"]], function(z) any_apply(Q[["formula"]][["type"]],
function(c) is_(z, c)))) {
P[["formula.list"]] <- NULL
}
#data
#model (only to extract data)
if (is_null(P[["data"]]) && is_not_null(x[["model"]]) && utils::hasName(x[["model"]], "data")) {
P[["data"]] <- x[["model"]][["data"]]
}
#weights
#distance
if (is_not_null(P[["distance"]])) {
if (is.list(P[["distance"]]) && !is.data.frame(P[["distance"]])) {
if (!all_apply(P[["distance"]], function(z) any_apply(Q[["distance"]][["type"]],
function(c) is_(z, c)))) {
P[["distance"]] <- NULL
}
}
else if (is.numeric(P[["distance"]])) {
P[["distance"]] <- setNames(data.frame(P[["distance"]]),
if_null_then(attr(P[["distance"]], "name", TRUE), "distance"))
}
else {
P[["distance"]] <- as.data.frame(P[["distance"]])
}
}
#distance.list
if (is_not_null(P[["distance.list"]]) &&
!all_apply(P[["distance.list"]], function(z) any_apply(Q[["distance"]][["type"]],
function(c) is_(z, c)))) {
P[["distance.list"]] <- NULL
}
#subclass
if (is_not_null(P[["subclass"]])) {
P[["subclass"]] <- factor(P[["subclass"]])
}
#match.strata
if (is_not_null(P[["match.strata"]])) {
P[["match.strata"]] <- factor(P[["match.strata"]])
}
#estimand
if (is_not_null(P[["estimand"]])) {
estimand.name <- attr(P[["estimand"]], "name", TRUE)
P[["estimand"]] <- {
if (is_not_null(estimand.name) && toupper(estimand.name) == "ATT") {
if (as.numeric(P[["estimand"]]) == 0) "ATE" else "ATT"
}
else if (is_not_null(estimand.name) && toupper(estimand.name) == "ATE") {
if (as.numeric(P[["estimand"]]) == 0) "ATT" else "ATE"
}
else if (tolower(P[["estimand"]]) %in% c("att", "treat", "treated", "tr", "t", "atet")) {
"ATT"
}
else if (tolower(P[["estimand"]]) %in% c("ate", "all")) {
"ATE"
}
else if (tolower(P[["estimand"]]) %in% c("atc", "control", "untreated", "u", "c", "ctrl", "atu", "atec", "ateu")) {
"ATC"
}
else {
NULL
}
}
}
#s.weights
#focal
#call
msm <- is_not_null(P[["treat.list"]]) || is_not_null(P[["formula.list"]])
if (msm) {
.x2base_default_msm(P, ...)
}
else {
.x2base_default_point(P, ...)
}
}
.x2base_default_point <- function(obj, ...) {
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
o.data <- obj[["data"]]
if (is_null(o.data) && is_not_null(obj[["model"]]) && utils::hasName(obj[["model"]], "data")) {
o.data <- obj[["model"]][["data"]]
}
if (inherits(o.data, "mids")) {
o.data <- .mids_complete(o.data)
}
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, o.data)
#Process treat
treat <- ...get("treat")
if (is_null(treat)) {
formula <- ...get("formula")
if (is_not_null(formula) && rlang::is_formula(formula, lhs = TRUE)) {
treat <- get_treat_from_formula(formula, data = if_null_then(data, o.data))
}
else if (is_not_null(obj[["treat"]])) {
treat <- obj[["treat"]]
}
else {
formula.obj <- obj[["formula"]]
if (is_not_null(formula.obj) && rlang::is_formula(formula.obj, lhs = TRUE)) {
treat <- get_treat_from_formula(formula.obj, data = if_null_then(data, o.data))
}
}
}
treat <- process_treat(treat, data, o.data)
#Process covs
covs <- ...get("covs")
if (is_null(covs)) {
formula <- ...get("formula")
if (is_not_null(formula) && rlang::is_formula(formula)) {
covs <- get_covs_from_formula(formula, data = if_null_then(data, o.data))
}
else if (is_not_null(obj[["covs"]])) {
covs <- obj[["covs"]]
}
else {
formula.obj <- obj[["formula"]]
if (is_not_null(formula.obj) && rlang::is_formula(formula.obj)) {
covs <- get_covs_from_formula(formula.obj, data = if_null_then(data, o.data))
}
}
}
if (is_null(covs)) {
.err("`covs` data.frame must be specified")
}
if (is_null(attr(covs, "co.names", TRUE))) {
if (is.matrix(covs)) covs <- as.data.frame.matrix(covs)
covs <- get_covs_from_formula(data = covs)
}
#Get estimand
estimand <- ...get("estimand", obj[["estimand"]])
#Get method
specified <- setNames(rep.int(FALSE, 3L), c("match.strata", "subclass", "weights"))
for (i in names(specified)) {
specified[i] <- is_not_null(...get(i, obj[[i]]))
}
.specified_method <- character()
.specified_args <- character()
.assuming <- character()
.ignoring <- character()
.not_present <- character()
.using <- character()
method <- ...get("method")
if (is_null(method)) {
if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.assuming <- method
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else {
method <- "matching"
}
}
else {
.specified_method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
if (length(method) == 1L) {
if (.specified_method == "weighting") {
if (specified["weights"]) {
method <- "weighting"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "weights"
}
else {
method <- "matching"
}
}
else if (.specified_method == "matching") {
if (specified["match.strata"]) {
method <- "matching"
.using <- "match.strata"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["weights"]) {
method <- "matching"
.using <- "weights"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
.not_present <- c("weights", "match.strata")
.assuming <- method
}
else {
method <- "matching"
}
}
else if (.specified_method == "subclassification") {
if (specified["subclass"]) {
method <- "subclassification"
.using <- "subclass"
if (sum(specified) > 1L) {
.specified_args <- names(specified)[specified]
.ignoring <- setdiff(names(specified)[specified], .using)
}
}
else if (any(specified)) {
.using <- names(specified)[specified][1L]
method <- switch(.using,
match.strata = "matching",
subclass = "subclassification",
weights = "weighting")
.assuming <- method
.not_present <- "subclass"
}
else {
method <- "matching"
}
}
}
else {
if (specified["subclass"] || any(.specified_method == "subclassification")) {
.err("subclassification cannot be specified along with other methods")
}
if (specified["match.strata"]) {
.err("only weights can be specified with multiple methods")
}
if (specified["weights"]) {
method <- .specified_method
.using <- "weights"
}
else {
.wrn("multiple methods were specified, but no weights were provided. Providing unadjusted data only")
method <- "matching"
}
}
}
.m <- NULL
if (is_not_null(.using)) {
if (is_not_null(.specified_args) && is_not_null(.ignoring)) {
if (is_not_null(.assuming)) {
.m <- sprintf("%s specified. Assuming %s and using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
else {
.m <- sprintf("%s specified. Using %s and ignoring %s",
word_list(.specified_args, and.or = "and", is.are = TRUE, quotes = "`"),
word_list(.using, and.or = "and", quotes = "`"),
word_list(.ignoring, and.or = "and", quotes = "`"))
}
}
else if (is_not_null(.specified_method) && is_not_null(.not_present) && is_not_null(.assuming)) {
.m <- sprintf("`method = %s` is specified, but %s was not supplied. Assuming %s and using %s instead",
add_quotes(.specified_method, 2L),
add_quotes(.not_present, "`"),
add_quotes(.assuming),
word_list(.using, and.or = "and", quotes = "`"))
}
}
if (is_not_null(.m)) {
.msg(.m)
}
#Process addl
addl <- process_addl(...get("addl"), datalist = list(data, o.data, covs))
#Process distance
distance <- process_distance(...get("distance"), datalist = list(data, o.data, covs),
obj.distance = obj[["distance"]],
obj.distance.name = attr(obj[["distance"]], "name", TRUE))
#Process focal
focal <- process_focal(...get("focal", obj[["focal"]]), treat)
if (get.treat.type(treat) == "binary") {
if (is_null(focal) && is_not_null(estimand)) {
focal <- switch(toupper(estimand),
"ATT" = treat_vals(treat)[treat_names(treat)["treated"]],
"ATC" = treat_vals(treat)[treat_names(treat)["control"]],
NULL)
}
#Process pairwise
if (is_null(focal) && isFALSE(...get("pairwise", TRUE))) {
attr(treat, "treat.type") <- "multinomial"
}
}
#Process subclass
if ("subclass" %in% .using) {
subclass <- .process_vector(...get("subclass", obj[["subclass"]]),
datalist = list(data, o.data),
name = "subclass",
which = "subclass membership",
missing.okay = TRUE) |>
factor()
weights <- NULL
}
#Process match.strata
if ("match.strata" %in% .using) {
match.strata <- .process_vector(...get("match.strata", obj[["match.strata"]]),
datalist = list(data, o.data),
name = "match.strata",
which = "matching strata membership",
missing.okay = TRUE)
weights <- data.frame(weights = strata2weights(match.strata,
treat = treat,
estimand = estimand,
focal = focal))
}
#Process weights
if ("weights" %in% .using) {
weights <- process_weights(obj, list(...), treat, covs, method, addl.data = list(data, o.data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", obj[["s.weights"]]), data, o.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, o.data)
#Process subset
subset <- process_subset(...get("subset"), length(treat))
#Process discarded
discarded <- ...get("discarded", obj[["discarded"]])
#Process length
length_imp_process(vectors = c("treat", "subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("covs", "weights", "distance", "addl"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs) || anyNA(addl)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
#Process output
X <- initialize_X()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names)
}
.x2base_default_msm <- function(obj, ...) {
#Process data and get imp
imp <- ...get("imp")
data <- ...get("data")
o.data <- obj[["data"]]
if (is_null(o.data) && is_not_null(obj[["model"]]) && utils::hasName(obj[["model"]], "data")) {
o.data <- obj[["model"]][["data"]]
}
if (inherits(o.data, "mids")) {
o.data <- .mids_complete(o.data)
}
if (is_not_null(data)) {
if (inherits(data, "mids")) {
data <- .mids_complete(data)
if (is_null(imp)) imp <- data[[".imp"]]
}
else if (!is.data.frame(data)) {
data <- NULL
}
}
#Process imp
imp <- process_imp(imp, data, o.data)
#Process treat.list
treat.list <- process_treat.list(...get("treat.list"), data)
treat.list <- ...get("treat.list")
if (is_null(treat.list)) {
formula.list <- ...get("formula.list")
if (is_not_null(formula.list) && all_apply(formula.list, rlang::is_formula, lhs = TRUE)) {
treat.list <- make_list(length(formula.list))
for (i in seq_along(formula.list)) {
treat.list[[i]] <- get_treat_from_formula(formula.list[[i]], data = if_null_then(data, o.data))
names(treat.list)[i] <- attr(treat.list[[i]], "treat.name")
}
}
else if (is_not_null(obj[["treat.list"]])) {
treat.list <- obj[["treat.list"]]
}
else {
formula.list.obj <- obj[["formula.list.obj"]]
if (is_not_null(formula.list.obj) && all_apply(formula.list.obj, rlang::is_formula, lhs = TRUE)) {
treat.list <- make_list(length(formula.list.obj))
for (i in seq_along(formula.list.obj)) {
treat.list[[i]] <- get_treat_from_formula(formula.list.obj[[i]], data = if_null_then(data, o.data))
names(treat.list)[i] <- attr(treat.list[[i]], "treat.name")
}
}
}
}
treat.list <- process_treat.list(treat.list, data, o.data)
#Process covs.list
covs.list <- ...get("covs.list")
if (is_null(covs.list)) {
formula.list <- ...get("formula.list")
if (is_not_null(formula.list) && all_apply(formula.list, rlang::is_formula)) {
covs.list <- make_list(length(formula.list))
for (i in seq_along(formula.list)) {
covs.list[[i]] <- get_covs_from_formula(formula.list[[i]], data = if_null_then(data, o.data))
}
}
else if (is_not_null(obj[["covs.list"]])) {
covs.list <- obj[["covs.list"]]
}
else {
formula.list.obj <- obj[["formula.list.obj"]]
if (is_not_null(formula.list.obj) && all_apply(formula.list.obj, rlang::is_formula)) {
covs.list <- make_list(length(formula.list.obj))
for (i in seq_along(formula.list.obj)) {
covs.list[[i]] <- get_covs_from_formula(formula.list.obj[[i]], data = if_null_then(data, o.data))
}
}
}
}
if (is_null(covs.list)) {
.err("`covs.list` must be specified")
}
if (!is.list(covs.list) || is.data.frame(covs.list)) {
.err("`covs.list` must be a list of covariates for which balance is to be assessed at each time point")
}
if (!all_apply(covs.list, is_mat_like)) {
.err("each item in `covs.list` must be a data frame")
}
if (any_apply(covs.list, function(z) is_null(attr(z, "co.names")))) {
covs.list <- lapply(covs.list, function(z) get_covs_from_formula(data = z))
}
if (length(treat.list) != length(covs.list)) {
.err("`treat.list` must be a list of treatment statuses at each time point")
}
#Get estimand
estimand <- "ATE"
#Get method
specified <- setNames(rep.int(FALSE, 1L), "weights")
for (i in names(specified)) {
specified[i] <- is_not_null(...get(i, obj[[i]]))
}
.using <- character()
method <- ...get("method")
if (is_null(method)) {
method <- if (specified["weights"]) "weighting" else "matching"
if (any(specified)) {
.using <- names(specified)[specified][1L]
}
}
else {
specified.method <- match_arg(method, c("weighting", "matching", "subclassification"), several.ok = TRUE)
method <- if (specified["weights"]) "weighting" else "matching"
if (any(specified)) {
.using <- names(specified)[specified][1L]
}
if (any(specified.method == "subclassification")) {
if (specified["weights"]) {
.wrn("only weighting is allowed with multiple treatment time points. Assuming weighting instead")
}
else {
.wrn("only weighting is allowed with multiple treatment time points. Providing unadjusted data only")
}
}
}
#Process addl.list
addl.list <- process_addl.list(...get("addl.list", ...get("addl")),
datalist = list(data, o.data),
covs.list = covs.list)
#Process distance
distance.list <- process_distance.list(...get("distance.list", ...get("distance", obj[["distance.list"]])),
datalist = list(data, o.data),
covs.list = covs.list)
#Process focal
focal <- ...get("focal")
if (is_not_null(focal)) {
.err("`focal` is not allowed with longitudinal treatments")
}
#Process subclass
if (is_not_null(...get("subclass"))) {
.err("subclasses are not allowed with longitudinal treatments")
}
#Process match.strata
if (is_not_null(...get("match.strata"))) {
.err("matching strata are not allowed with longitudinal treatments")
}
#Process weights
if ("weights" %in% .using) {
weights <- process_weights(obj, list(...), treat.list[[1L]], covs.list[[1L]],
method, addl.data = list(data, o.data))
method <- attr(weights, "method")
}
#Process s.weights
s.weights <- process_s.weights(...get("s.weights", obj[["s.weights"]]),
data, o.data)
#Process cluster
cluster <- process_cluster(...get("cluster"), data, o.data)
.cluster_check(cluster, treat.list)
#Process subset
subset <- process_subset(...get("subset"), min(lengths(treat.list)))
#Process discarded
#Process length
length_imp_process(vectors = c("subclass", "match.strata", "cluster", "s.weights", "subset", "discarded"),
data.frames = c("weights"),
lists = c("covs.list", "treat.list", "addl.list", "distance.list"),
imp = imp)
#Process stats and thresholds
if (!check_if_call_from_fun(bal.plot)) {
stats <- process_stats(...get("stats"), treat = treat.list)
type <- attr(stats, "type")
thresholds <- ...get("thresholds", list())
if (is_not_null(thresholds)) {
thresholds <- process_thresholds(thresholds, c(stats, setdiff(all_STATS(type), stats)))
if (!all(names(thresholds) %in% stats)) {
stats <- unique(c(stats, names(thresholds)))
}
}
for (s in all_STATS(type)) {
#If disp.stat is TRUE, add stat to stats
if (isTRUE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- unique(c(stats, s))
}
else if (isFALSE(...get(STATS[[s]][["disp_stat"]]))) {
stats <- setdiff(stats, s)
}
#Process and check thresholds
if (is_not_null(...get(STATS[[s]][["threshold"]]))) {
thresholds[[s]] <- ...get(STATS[[s]][["threshold"]])
}
if (is_not_null(thresholds[[s]])) {
thresholds[[s]] <- STATS[[s]][["abs"]](thresholds[[s]])
if (between(thresholds[[s]], STATS[[s]][["threshold_range"]])) {
stats <- unique(c(stats, s))
}
else {
thresholds[[s]] <- NULL
.wrn(sprintf("%s must be between %s; ignoring %s",
add_quotes(STATS[[s]][["threshold"]], "`"),
word_list(STATS[[s]][["threshold_range"]]),
add_quotes(STATS[[s]][["threshold"]], "`")))
}
}
}
stats <- process_stats(stats, treat = treat.list)
#Get s.d.denom
s.d.denom <- ...get("s.d.denom")
}
#Missing values warning
if (anyNA(covs.list, recursive = TRUE) || anyNA(addl.list, recursive = TRUE)) {
.wrn("missing values exist in the covariates. Displayed values omit these observations")
}
#Get call
call <- NULL
#Process output
X <- initialize_X_msm()
X.names <- names(X)
for (i in X.names) {
X[[i]] <- get0(i, inherits = FALSE)
}
X <- subset_X(X, subset)
setNames(X[X.names], X.names) |>
set_class("msm")
}
Try the cobalt package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.