Merge pull request #33 from r-causal/weights_improvements

Weights improvements

Author: malcolmbarrett

DESCRIPTION

@@ -15,16 +15,18 @@ Imports:
     cli,
     rlang,
     stats,
+    tidyselect,
     vctrs (>= 0.6.5)
 Suggests: 
     dplyr,
     ggplot2,
     mgcv,
+    parsnip,
     probably,
     PSweight,
     spelling,
     testthat (>= 3.0.0),
-    tidyselect,
+    tibble,
     WeightIt
 Config/testthat/edition: 3
 Encoding: UTF-8

NAMESPACE

@@ -81,21 +81,39 @@ S3method(vec_ptype_abbr,psw)
 S3method(vec_ptype_full,ps_trim)
 S3method(vec_ptype_full,ps_trunc)
 S3method(vec_ptype_full,psw)
+S3method(wt_ate,data.frame)
+S3method(wt_ate,default)
+S3method(wt_ate,glm)
 S3method(wt_ate,numeric)
 S3method(wt_ate,ps_trim)
 S3method(wt_ate,ps_trunc)
+S3method(wt_atm,data.frame)
+S3method(wt_atm,default)
+S3method(wt_atm,glm)
 S3method(wt_atm,numeric)
 S3method(wt_atm,ps_trim)
 S3method(wt_atm,ps_trunc)
+S3method(wt_ato,data.frame)
+S3method(wt_ato,default)
+S3method(wt_ato,glm)
 S3method(wt_ato,numeric)
 S3method(wt_ato,ps_trim)
 S3method(wt_ato,ps_trunc)
+S3method(wt_att,data.frame)
+S3method(wt_att,default)
+S3method(wt_att,glm)
 S3method(wt_att,numeric)
 S3method(wt_att,ps_trim)
 S3method(wt_att,ps_trunc)
+S3method(wt_atu,data.frame)
+S3method(wt_atu,default)
+S3method(wt_atu,glm)
 S3method(wt_atu,numeric)
 S3method(wt_atu,ps_trim)
 S3method(wt_atu,ps_trunc)
+S3method(wt_entropy,data.frame)
+S3method(wt_entropy,default)
+S3method(wt_entropy,glm)
 S3method(wt_entropy,numeric)
 S3method(wt_entropy,ps_trim)
 S3method(wt_entropy,ps_trunc)

R/weights-utils.R

@@ -8,9 +8,10 @@ abort_unsupported <- function(exposure_type, what, call = rlang::caller_env()) {
 
 match_exposure_type <- function(
   exposure_type = c("auto", "binary", "categorical", "continuous"),
-  .exposure
+  .exposure,
+  valid_types = c("auto", "binary", "categorical", "continuous")
 ) {
-  .exposure_type <- rlang::arg_match(exposure_type)
+  .exposure_type <- rlang::arg_match(exposure_type, valid_types)
   if (.exposure_type == "auto") {
     detect_exposure_type(.exposure)
   } else {
@@ -128,3 +129,26 @@ check_lower_upper <- function(lower, upper, call = rlang::caller_env()) {
 
   invisible(TRUE)
 }
+
+check_lengths_match <- function(
+  .propensity,
+  .exposure,
+  call = rlang::caller_env()
+) {
+  len_prop <- length(.propensity)
+  len_exp <- length(.exposure)
+
+  if (len_prop != len_exp) {
+    abort(
+      c(
+        "{.arg .propensity} and {.arg .exposure} must have the same length.",
+        i = "{.arg .propensity} has length {len_prop}",
+        i = "{.arg .exposure} has length {len_exp}"
+      ),
+      call = call,
+      error_class = "propensity_length_error"
+    )
+  }
+
+  invisible(TRUE)
+}