version 4.4.1

cran · Nov 3, 2022 · 94c09b4 · 94c09b4
1 parent 34b0bae
commit 94c09b4
Show file tree

Hide file tree

Showing 27 changed files with 1,119 additions and 874 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: cobalt
 Title: Covariate Balance Tables and Plots
-Version: 4.4.0
+Version: 4.4.1
 Authors@R: c(
     person("Noah", "Greifer", role=c("aut", "cre"), 
            email = "noah.greifer@gmail.com",
@@ -19,17 +19,19 @@ Imports: ggplot2 (>= 3.3.0), grid, gtable (>= 0.3.0), gridExtra (>=
 Suggests: MatchIt (>= 4.0.0), WeightIt (>= 0.12.0), twang (>= 1.6),
         twangContinuous, Matching, optmatch, ebal, CBPS (>= 0.17),
         designmatch, optweight, mice (>= 3.8.0), MatchThem (>= 0.9.3),
-        cem (>= 1.1.30), sbw (>= 1.1.5), knitr, rmarkdown
+        cem (>= 1.1.30), sbw (>= 1.1.5), knitr, rmarkdown, testthat (>=
+        3.0.0)
 License: GPL (>= 2)
 Encoding: UTF-8
 LazyData: true
 VignetteBuilder: knitr
 URL: https://ngreifer.github.io/cobalt/,
         https://github.com/ngreifer/cobalt
 BugReports: https://github.com/ngreifer/cobalt/issues
+Config/testthat/edition: 3
 NeedsCompilation: no
-Packaged: 2022-08-13 18:51:36 UTC; NoahGreifer
+Packaged: 2022-11-03 06:51:00 UTC; NoahGreifer
 Author: Noah Greifer [aut, cre] (<https://orcid.org/0000-0003-3067-7154>)
 Maintainer: Noah Greifer <noah.greifer@gmail.com>
 Repository: CRAN
-Date/Publication: 2022-08-15 08:30:05 UTC
+Date/Publication: 2022-11-03 17:30:02 UTC
diff --git a/MD5 b/MD5
@@ -1,45 +1,45 @@
-e78b2aef8b829ee1550c289521ca7dc6 *DESCRIPTION
+ac917f86c8b54e4cbadba5e1036a56a6 *DESCRIPTION
 87e50e5c510151284adf67234dbf29ed *NAMESPACE
-aaf085b15fbcee5a76d621740720fce4 *NEWS.md
-e115ba6c5e2064b573ccec98d7b09a23 *R/SHARED.R
+f28fc7fbb33412446dbc794f13f79c1f *NEWS.md
+b473ddc8ac5a8b9100ee572ef96f5254 *R/SHARED.R
 5507eb242b8227d881eb6f0afa8083e0 *R/STATS.R
-25e48a125fd95955116b2809caa7d4e5 *R/bal.plot.R
+5b0c33d520eb3a61addcfcd4fddc5131 *R/bal.plot.R
 0fd61ec00df4bed6113c891f83f8c82e *R/bal.sum.R
-5e89106512176ea76332d57a6ddfb678 *R/bal.tab.R
-9eff51e884bfbfcec90b0fb2a0fa94de *R/base.bal.tab.R
-6477180dabfc36eb32a054aa0156ab9b *R/functions_for_processing.R
+be327811eca3e3ac3a1eb9b52f360656 *R/bal.tab.R
+5e24529506e2752c36958c006226c742 *R/base.bal.tab.R
+9a108ef78f8ed09553fe1e3a9704a4ca *R/functions_for_processing.R
 c975357d4b1f26c61fd38ffd5ac812f6 *R/get.w.R
 39a7d6bda738d6ce0b186fbec81d1757 *R/love.plot.R
 71d58396ff9f061625aa7545af3d8c8d *R/print.bal.tab.R
 cebecb06a24433d6f394a4b86faeedc6 *R/utilities.R
-e6d629d34e88ccc5375550b6c1d281f7 *R/x2base.R
+b5af8c4dfc9a87e5caa5236206872cd7 *R/x2base.R
 08079fd147eb1f5a598a23e69b86baf4 *R/zzz.R
-ccdeef32d38f56af4e51484465aa22e2 *README.md
-4896389b17a966d0ce62a782bc64bcbe *build/cobalt.pdf
-ff476854de2ccdd3bc8543407c05570f *build/partial.rdb
+6a7de8aee2621c6006ec0f347f48a4c1 *README.md
+da289b8234245679ba4dc5606396aad7 *build/cobalt.pdf
+79c92077072409c804fe9dc855785ed9 *build/partial.rdb
 6df1ccdfa825346e4806ec408a619bc3 *build/vignette.rds
 949b492287de79b9a90d520db98768c1 *data/lalonde.RData
 d22e5afa667cdc190e348ae984c830a2 *data/lalonde_mis.RData
 7f7b5e57e80618fa4430b35f7b70b543 *inst/WORDLIST
-7d407a65afdba130165f93fce5d9008b *inst/doc/cobalt.R
-bb14d4a8f1f4e5406f057667c420c514 *inst/doc/cobalt.Rmd
-004f5c65efb46899ab78abe741f63308 *inst/doc/cobalt.html
+1e669e9a5934b24c5a176e61398ed611 *inst/doc/cobalt.R
+5078e51d6a95c727abc5aec8e4035064 *inst/doc/cobalt.Rmd
+5cd68edd62cd49df94e24a85ea434169 *inst/doc/cobalt.html
 01782031013a01f21d1e3d11e2268d80 *inst/doc/cobalt_A1_other_packages.R
 3fb090a996cb527b2a21c106e56dd6f1 *inst/doc/cobalt_A1_other_packages.Rmd
-f861f3f5787a40c56940ea0e295e62c5 *inst/doc/cobalt_A1_other_packages.html
+b0bc1021e7a125c79be672dfcc37350b *inst/doc/cobalt_A1_other_packages.html
 a220c3858ab94a92995dc110bffc0e41 *inst/doc/cobalt_A2_segmented_data.R
 ab0ec319cf2eff121d96b142b3cd2c9e *inst/doc/cobalt_A2_segmented_data.Rmd
-3762c7815ed5f57472e43687e92c989d *inst/doc/cobalt_A2_segmented_data.html
+e9781b707107ba621698dcc567dba06f *inst/doc/cobalt_A2_segmented_data.html
 44e233ea7f7ab2109ef6b834e4928a74 *inst/doc/cobalt_A3_longitudinal_treat.R
 0e41e67b6a21463765cfa8da3ed8a72e *inst/doc/cobalt_A3_longitudinal_treat.Rmd
-47ff040ad286a9ba87b789b3445df3fd *inst/doc/cobalt_A3_longitudinal_treat.html
+b0cd53e5bece31549eda486a6ed5e8cf *inst/doc/cobalt_A3_longitudinal_treat.html
 14e086d8a4708bc3f1258ccc4fee4ebf *inst/doc/cobalt_A4_love.plot.R
 78ee39e97ea4e39af4a19fea5862377c *inst/doc/cobalt_A4_love.plot.Rmd
-68e0b945e8845e6e53b38cda1fc70b0f *inst/doc/cobalt_A4_love.plot.html
+98198255d78421c550914528c26948da *inst/doc/cobalt_A4_love.plot.html
 f8a3f5a19257b0dd27f14799c7023210 *man/bal.plot.Rd
 5277da13238b3857d3f0b89284264f64 *man/bal.tab.CBPS.Rd
 3dbeeef01687ff43b8357dfa55e5fce5 *man/bal.tab.Match.Rd
-a27c19b7b3c55424adbc3ec9606f2b6f *man/bal.tab.Rd
+8de6af10fe1286f842386e995ddb7dec *man/bal.tab.Rd
 0b9322821ed1c5d458989c444b1b7e26 *man/bal.tab.cem.match.Rd
 d80074761fa07aef27d218226aa68b4c *man/bal.tab.default.Rd
 70fefec8af15a31e8e3aa66d51905019 *man/bal.tab.df.formula.Rd
@@ -57,7 +57,7 @@ f01a6f9828e08fe6619b8df73a37adde *man/class-bal.tab.imp.Rd
 2e8414f1c5597c0b5583f858e2684b03 *man/class-bal.tab.multi.Rd
 ee326ecd5a42f522d086504104a82ec0 *man/class-bal.tab.subclass.Rd
 427359dc95bb3104d3bc92199da435f5 *man/cobalt-package.Rd
-14fd30d6aa0b4669a4688b6f3dd0641d *man/display_options.Rd
+63d5ac2de91fb994a02b0d04c047f079 *man/display_options.Rd
 a34b444102fcbec1b1c0c086070ed8c2 *man/f.build.Rd
 3df5283aeffe9fca2cb34d1bf594fd05 *man/figures/README-unnamed-chunk-3-1.png
 b986e3c809d19accb508ff3f7ee032df *man/figures/README-unnamed-chunk-3-2.png
@@ -67,14 +67,17 @@ bb84608f3b18d1092b1d0cd6953d7dde *man/figures/logo.png
 7d701af1a40e7494d8cc0bb9b647f13f *man/get.w.Rd
 442f035d94de3cc5b4d37d352326ff7c *man/lalonde.Rd
 ef1261d9a9ceb1c5c5d6439f2d47f910 *man/love.plot.Rd
-0edd4f54234e47f832fe2786e8037a00 *man/macros/macros.Rd
+ca8b677de6b46506f3f4f9d525de5b15 *man/macros/macros.Rd
 f5da5e0e52641a902d0d4b135a99379f *man/print.bal.tab.Rd
 8404e20cb0a62f5c1c4ed90bd9e139ff *man/set.cobalt.options.Rd
 2a0450dacab2f7fd1ab4d722384a03aa *man/splitfactor.Rd
 8d505f73c1c70c5aa95aaa618dcbc370 *man/var.names.Rd
-bb14d4a8f1f4e5406f057667c420c514 *vignettes/cobalt.Rmd
+b8dcf5a839f4fea80ab6a6a41008639c *tests/testthat.R
+f4fce1434d0e626fa5903fb5df06da34 *tests/testthat/test-bal.tab.data.frame.R
+3f972a07ac39c7c69d2ee494fe252862 *tests/testthat/test-bal.tab.weightit.R
+5078e51d6a95c727abc5aec8e4035064 *vignettes/cobalt.Rmd
 3fb090a996cb527b2a21c106e56dd6f1 *vignettes/cobalt_A1_other_packages.Rmd
 ab0ec319cf2eff121d96b142b3cd2c9e *vignettes/cobalt_A2_segmented_data.Rmd
 0e41e67b6a21463765cfa8da3ed8a72e *vignettes/cobalt_A3_longitudinal_treat.Rmd
 78ee39e97ea4e39af4a19fea5862377c *vignettes/cobalt_A4_love.plot.Rmd
-2439051bd01ddad8d75bc6e51d16465c *vignettes/references.bib
+78b3ced811d3a6ab45bf7f66c2591f26 *vignettes/references.bib
diff --git a/NEWS.md b/NEWS.md
@@ -1,6 +1,18 @@
 `cobalt` News and Updates
 ======
 
+# cobalt 4.4.1
+
+* Fixed a bug when covariates with nonstandard names are extracted from model objects (#63). Thanks to @markdanese.
+
+* Fixed a bug when "0" and "1" are the names of two of the treatment levels in a multinomial treatment.
+
+* Fixed a bug with the default method of `bal.tab()` which was ignoring components of the supplied object.
+
+* Fixed a bug where `bal.plot()` would ignore `s.weights`. They are now included correctly.
+
+* The call to the original balancing function is now hidden by default. To request it be displayed, set `disp.call = TRUE` in the call to `bal.tab()` or `print.bal.tab()` or use `set.cobalt.options(disp.call = TRUE)` to display it for the session.
+
 # cobalt 4.4.0
 
 * Added support in `bal.plot()` for negative weights with `type = "density"`.

diff --git a/R/SHARED.R b/R/SHARED.R
@@ -152,11 +152,15 @@ text_box_plot <- function(range.list, width = 12) {
         #|
         spaces2 <- max(c(0, diff(rescaled.full.range) - (spaces1 + 1 + dashes + 1)))
 
-        d[i, 2] <- paste0(paste(rep(" ", spaces1), collapse = ""), "|", paste(rep("-", dashes), collapse = ""), "|", paste(rep(" ", spaces2), collapse = ""))
+        d[i, 2] <- paste0(paste(rep(" ", spaces1), collapse = ""),
+                          "|",
+                          paste(rep("-", dashes), collapse = ""),
+                          "|",
+                          paste(rep(" ", spaces2), collapse = ""))
     }
     return(d)
 }
-equivalent.factors <- function(f1, f2) {
+.equivalent.factors <- function(f1, f2) {
     if (is_(f1, c("character", "factor")) && is_(f1, c("character", "factor"))) {
         nu1 <- nunique(f1)
         nu2 <- nunique(f2)
@@ -171,9 +175,35 @@ equivalent.factors <- function(f1, f2) {
         return(FALSE)
     }
 }
-equivalent.factors2 <- function(f1, f2) {
+.equivalent.factors2 <- function(f1, f2) {
     return(qr(cbind(1, as.numeric(f1), as.numeric(f2)))$rank == 2)
 }
+equivalent.factors2 <- function(f1, f2) {
+    if (is_(f1, c("character", "factor")) && is_(f1, c("character", "factor"))) {
+        f1 <- as.factor(f1)
+        f2 <- as.factor(f2)
+        ll1 <- levels(f1)
+        ll2 <- levels(f2)
+        f1 <- as.integer(f1)
+        f2 <- as.integer(f2)
+        nl1 <- length(ll1)
+        nl2 <- length(ll2)
+
+        dims <- c(nl1, nl2)
+        dn <- list(ll1, ll2)
+
+        bin <- f1 + nl1 * (f2 - 1L)
+        pd <- nl1 * nl2
+
+        tab_ <- array(tabulate(bin, pd), dims, dimnames = dn)
+
+        return(all(colSums(tab_ != 0) %in% 0:1) && all(rowSums(tab_ != 0) %in% 0:1))
+    }
+    else {
+        return(FALSE)
+    }
+}
+
 paste. <- function(..., collapse = NULL) {
     #Like paste0 but with sep = ".'
     paste(..., sep = ".", collapse = collapse)
@@ -384,7 +414,7 @@ col.w.v <- function(mat, w = NULL, bin.vars = NULL, na.rm = TRUE) {
         w <- w/sum(w)
         if (non.bin.vars.present) {
             x <- center(mat[, !bin.vars, drop = FALSE],
-                                  at = colSums(w * mat[, !bin.vars, drop = FALSE], na.rm = na.rm))
+                        at = colSums(w * mat[, !bin.vars, drop = FALSE], na.rm = na.rm))
             var[!bin.vars] <- colSums(w*x*x, na.rm = na.rm)/(1 - sum(w^2))
         }
         if (bin.var.present) {
@@ -753,12 +783,11 @@ process.s.weights <- function(s.weights, data = NULL) {
 #Uniqueness
 nunique <- function(x, nmax = NA, na.rm = TRUE) {
     if (is_null(x)) return(0)
-    else {
-        if (na.rm && anyNA(x)) x <- na.rem(x)
-        if (is.factor(x)) return(nlevels(x))
-        else return(length(unique(x, nmax = nmax)))
-    }
 
+    if (na.rm && anyNA(x)) x <- na.rem(x)
+    # if (is.factor(x)) return(nlevels(x))
+    # else 
+    return(length(unique(x, nmax = nmax)))
 }
 nunique.gt <- function(x, n, na.rm = TRUE) {
     if (missing(n)) stop("'n' must be supplied.")

diff --git a/R/bal.plot.R b/R/bal.plot.R
@@ -128,6 +128,8 @@ bal.plot <- function(x, var.name, ..., which, which.sub = NULL, cluster = NULL,
     }
     else weight.names <- "adjusted"
 
+    if (is_null(X$s.weights)) X$s.weights <- rep(1, length(X$treat))
+
     if (missing(which)) {
         if (is_not_null(args$un)) {
             message("Note: \'un\' is deprecated; please use \'which\' for the same and added functionality.")
@@ -322,21 +324,22 @@ bal.plot <- function(x, var.name, ..., which, which.sub = NULL, cluster = NULL,
 
         nobs <- sum(in.imp & in.cluster & in.time)
         if (nobs == 0) stop("No observations to display.", call. = FALSE)
-        
-        Q <- make_list(which)
+
+        D <- make_list(which)
         for (i in which) {
-            Q[[i]] <- make_df(c("treat", "var", "weights", "which"), nobs)
-            Q[[i]]$treat <- X$treat[in.imp & in.cluster & in.time]
-            Q[[i]]$var <- X$var[in.imp & in.cluster & in.time]
-            Q[[i]]$weights <-  X$weights[in.imp & in.cluster & in.time, i]
-            Q[[i]]$which <- i
+            D[[i]] <- make_df(c("treat", "var", "weights", "s.weights", "which"), nobs)
+            D[[i]]$treat <- X$treat[in.imp & in.cluster & in.time]
+            D[[i]]$var <- X$var[in.imp & in.cluster & in.time]
+            D[[i]]$weights <-  X$weights[in.imp & in.cluster & in.time, i]
+            D[[i]]$s.weights <- X$s.weights[in.imp & in.cluster & in.time]
+            D[[i]]$which <- i
 
             #Add columns for additional facets
-            if ("imp" %in% facet) Q[[i]]$imp <- factor(paste("Imputation", X$imp[in.imp & in.cluster & in.time]))
-            if ("cluster" %in% facet) Q[[i]]$cluster <- factor(X$cluster[in.imp & in.cluster & in.time])
-            if ("time" %in% facet) Q[[i]]$time <- factor(paste("Time", X$time[in.imp & in.cluster & in.time]))
+            if ("imp" %in% facet) D[[i]]$imp <- factor(paste("Imputation", X$imp[in.imp & in.cluster & in.time]))
+            if ("cluster" %in% facet) D[[i]]$cluster <- factor(X$cluster[in.imp & in.cluster & in.time])
+            if ("time" %in% facet) D[[i]]$time <- factor(paste("Time", X$time[in.imp & in.cluster & in.time]))
         }
-        D <- do.call(rbind, Q)
+        D <- do.call(rbind, D)
 
         D$which <- factor(D$which, levels = which)
 
@@ -402,16 +405,18 @@ bal.plot <- function(x, var.name, ..., which, which.sub = NULL, cluster = NULL,
         }
 
         in.sub <- !is.na(X$subclass) & X$subclass %in% which.sub
-        D <- make_df(c("weights", "treat", "var", "subclass"), sum(in.sub))
+        D <- make_df(c("weights", "s.weights", "treat", "var", "subclass"), sum(in.sub))
         D$weights <- 1
+        D$s.weights <- X$s.weights[in.sub]
         D$treat <- X$treat[in.sub]
         D$var <- X$var[in.sub]
         D$subclass <- paste("Subclass", X$subclass[in.sub])
 
         if (which == "both") {
             #Make unadjusted sample
-            D2 <- make_df(c("weights", "treat", "var", "subclass"), length(X$treat))
+            D2 <- make_df(c("weights", "s.weights", "treat", "var", "subclass"), length(X$treat))
             D2$weights <- 1
+            D$s.weights <- X$s.weights
             D2$treat <- X$treat
             D2$var <- X$var
             D2$subclass <- rep("Unadjusted Sample", length(X$treat))
@@ -480,7 +485,7 @@ bal.plot <- function(x, var.name, ..., which, which.sub = NULL, cluster = NULL,
 
             }
 
-            D$weights <- ave(D[["weights"]], 
+            D$weights <- ave(D[["weights"]] * D[["s.weights"]], 
                              D[c("var", facet)], 
                              FUN = function(x) x/sum(x))
 
@@ -493,10 +498,12 @@ bal.plot <- function(x, var.name, ..., which, which.sub = NULL, cluster = NULL,
                 ggplot2::scale_y_continuous(expand = ggplot2::expansion(mult = c(0, .05)))
         }
         else { #Continuous vars
-            D$var.mean <- ave(D[["var"]], D[facet], FUN = mean)
-            D$treat.mean <- ave(D[["treat"]], D[facet], FUN = mean)
+            D$var.mean <- ave(D[c("var", "s.weights")], D[facet], 
+                              FUN = function(x) w.m(x[[1]], x[[2]]))[[1]]
+            D$treat.mean <- ave(D[c("treat", "s.weights")], D[facet], 
+                                FUN = function(x) w.m(x[[1]], x[[2]]))[[1]]
 
-            bp <- ggplot2::ggplot(D, mapping = aes(x = .data$var, y = .data$treat, weight = .data$weights))
+            bp <- ggplot2::ggplot(D, mapping = aes(x = .data$var, y = .data$treat, weight = .data$weights * .data$s.weights))
 
             if (identical(which, "Unadjusted Sample") || isFALSE(alpha.weight)) bp <- bp + ggplot2::geom_point(alpha = .9)
             else bp <- bp + ggplot2::geom_point(aes(alpha = .data$weights), show.legend = FALSE) + 
@@ -545,7 +552,7 @@ bal.plot <- function(x, var.name, ..., which, which.sub = NULL, cluster = NULL,
 
         for (i in names(D)[vapply(D, is.factor, logical(1L))]) D[[i]] <- factor(D[[i]])
 
-        D$weights <- ave(D[["weights"]], 
+        D$weights <- ave(D[["weights"]] * D[["s.weights"]], 
                          D[c("treat", facet)], 
                          FUN = function(x) x/sum(x))