Skip to content

Commit

Permalink
version 4.2.2
Browse files Browse the repository at this point in the history
  • Loading branch information
@ngreifer @cran-robot
ngreifer authored and cran-robot committed Jun 26, 2020
1 parent 7c3425b commit 5f99883
Show file tree
Hide file tree
Showing 21 changed files with 408 additions and 495 deletions.
6 changes: 3 additions & 3 deletions DESCRIPTION
View file
@@ -1,6 +1,6 @@
Package: cobalt
Title: Covariate Balance Tables and Plots
Version: 4.2.1
Version: 4.2.2
Authors@R: c(
person("Noah", "Greifer", role=c("aut", "cre"),
email = "noah.greifer@gmail.com",
Expand All @@ -21,8 +21,8 @@ VignetteBuilder: knitr
URL: https://github.com/ngreifer/cobalt
BugReports: https://github.com/ngreifer/cobalt/issues
NeedsCompilation: no
Packaged: 2020-06-20 18:51:08 UTC; NoahGreifer
Packaged: 2020-06-25 22:30:56 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: 2020-06-20 19:10:03 UTC
Date/Publication: 2020-06-26 15:50:03 UTC
40 changes: 20 additions & 20 deletions MD5
View file
@@ -1,44 +1,44 @@
67a674d9688df26626ccaf1cf59f0e7d *DESCRIPTION
bcf238412c4f9a7acf4454efd6d0b456 *DESCRIPTION
46aabb4510652c551b85c3c8b2971642 *NAMESPACE
e2c14dd496f3f3957bc0e1519aa1b23f *NEWS.md
5ea528286564ba6be7c4533b7a26fcd1 *R/SHARED.R
c747f69463b509500667b9bcfe494e8c *NEWS.md
68ed5b9b4ee15495d4a9e025f6c88dc3 *R/SHARED.R
ceab4463d956790b12996db9ee7be2d4 *R/STATS.R
d7bea767d41309b3d30c2f78ba7c3834 *R/bal.plot.R
c3c3857e30e7064da4c62fa73f4d81f7 *R/bal.sum.R
4f45ca40c80815ef66b0e9af90d387a5 *R/bal.plot.R
d95b8f15e9356e735f28793652d7f9a4 *R/bal.sum.R
04925d2415ae4aea3ed74b99f18f1ff5 *R/bal.tab.R
45bd784cb46b884615ca176fa3d26843 *R/base.bal.tab.R
5159fc58d1b111477cf5e3db28962e65 *R/functions_for_processing.R
4f584011d24e958712a9e36ffdd7d89b *R/get.w.R
8e439931644a2380decd4685ba130085 *R/love.plot.R
f59e0e57d273cd4b99b2925e24dd51f9 *R/print.bal.tab.R
94b31d3f74f053ef8702829c69674850 *R/utilities.R
92dbf50bcd2703843bd9e6bde860af76 *R/x2base.R
b0227d0ae50acd1415a3c16364e82dae *R/base.bal.tab.R
237ce50aead9cd9fd3526680a7f0db23 *R/functions_for_processing.R
e2e045550f8fe7085f74fd1305b29070 *R/get.w.R
cba2e72a317a09becc25f8f6421413a0 *R/love.plot.R
325cb05e7f8891d25ea8fc2d8a771cbb *R/print.bal.tab.R
ec51dc1c33cc3d05e2b01c90165c61fa *R/utilities.R
e7a37ac144f05d84181d4d705ae0c6ce *R/x2base.R
1c83e35ae6036807306c7e5222e3fba0 *README.md
4bb94c2c6f5b19262224d251d2db93f3 *build/partial.rdb
3505b57c8113af475e0b95d9f9de0d27 *build/partial.rdb
c8ca83583e5aeedb64b1a4a6a5b02652 *build/vignette.rds
949b492287de79b9a90d520db98768c1 *data/lalonde.RData
d22e5afa667cdc190e348ae984c830a2 *data/lalonde_mis.RData
7f7b5e57e80618fa4430b35f7b70b543 *inst/WORDLIST
71178df70eeeb2558d995b76588025a6 *inst/doc/cobalt_A0_basic_use.R
2afb1235cef8964deb72f0527c5c080d *inst/doc/cobalt_A0_basic_use.Rmd
c81a121104d9af36fc6b1943a1b5d22e *inst/doc/cobalt_A0_basic_use.html
d46f03fdee8b1ab8360f79784a1e8853 *inst/doc/cobalt_A0_basic_use.html
200947f59b32524592880adf576505ea *inst/doc/cobalt_A1_other_packages.R
024541a49774c597ec42e92df7d36705 *inst/doc/cobalt_A1_other_packages.Rmd
446d167c864b6b63a1cef7cf07e38599 *inst/doc/cobalt_A1_other_packages.html
2a01d625530449a3d9e20c06fc86a7c4 *inst/doc/cobalt_A1_other_packages.html
61fd85063bbb6833ae45e4014d50780a *inst/doc/cobalt_A2_segmented_data.R
df889ad647ad175b476e79dc497ce335 *inst/doc/cobalt_A2_segmented_data.Rmd
92ac4e24d3588a7cc7b0ce6971f53b8a *inst/doc/cobalt_A2_segmented_data.html
f150decfac61834af46019eff97800c9 *inst/doc/cobalt_A2_segmented_data.html
d85a44ba45b651cf45d44df718b899f8 *inst/doc/cobalt_A3_longitudinal_treat.R
7191dcb5d34eb5707f6b4fd8a0ad4d90 *inst/doc/cobalt_A3_longitudinal_treat.Rmd
78dbfc01e769d15622e24dc5afd7f4a6 *inst/doc/cobalt_A3_longitudinal_treat.html
95edb5945bea99232287a711df9618f2 *inst/doc/cobalt_A3_longitudinal_treat.html
f43c44694b17df4e01acf22396a273b7 *inst/doc/cobalt_A4_love.plot.R
15517aefcce8b433a71d10094543d261 *inst/doc/cobalt_A4_love.plot.Rmd
64d2d627a9917d8f63cb28902a6f7b96 *inst/doc/cobalt_A4_love.plot.html
a98e93be9380d62bf456ba0434c4c302 *inst/doc/cobalt_A4_love.plot.html
1d5d010766d4d4ce2f38e9b6a2778291 *inst/figures/README-unnamed-chunk-3-1.png
8ec0a533a1834419567a80f661fa3021 *inst/figures/README-unnamed-chunk-3-2.png
797f8b0a88cb066430299b3ae748efa8 *inst/figures/README-unnamed-chunk-3-3.png
004e9409ef9b52acb3c3cc390fd6555f *inst/figures/README-unnamed-chunk-4-1.png
c2f775ea9cfab321688040a489ef17af *man/bal.plot.Rd
dd13b2a2ede9453a17ec5f3b26f2298c *man/bal.plot.Rd
aacf89fa7dd5e0675c9b8b87b42932fb *man/bal.tab.CBPS.Rd
fe6f838eeee58c235134eaf7740c0970 *man/bal.tab.Match.Rd
066bacd44dffa63c6e486bada87791f7 *man/bal.tab.Rd
Expand All @@ -49,7 +49,7 @@ b7285854828665c996e18e2cb8982637 *man/bal.tab.default.Rd
7582dd8006b3d93729d7619e22503ef1 *man/bal.tab.matchit.Rd
37322120a32935b8a7e8c19a21a796f7 *man/bal.tab.mimids.Rd
e24672b0305d4f830d221236b3b539cc *man/bal.tab.ps.Rd
2debf587926999730f3dd7e7b2fb5037 *man/bal.tab.sbw.Rd
5e5a54978634d0a6995a53d854ad5353 *man/bal.tab.sbw.Rd
c95932c95f2e8c46dd0040765a887a3a *man/bal.tab.weightit.Rd
28c8d7a28168c543f1d3aa7d90c9267d *man/balance.stats.Rd
e6e18f49dcbd598f9c8cec998fcf8696 *man/balance.summary.Rd
Expand Down
6 changes: 6 additions & 0 deletions NEWS.md
View file
@@ -1,6 +1,12 @@
`cobalt` News and Updates
======

Version 4.2.2

* Fixed a bug due to new version of `sbw`.

* Minor improvements to error messages and documentation.

Version 4.2.1

* Fixed a bug where `int` and `poly` were ignored with binary and continuous treatments.
Expand Down
164 changes: 51 additions & 113 deletions R/SHARED.R
View file
Expand Up @@ -71,7 +71,7 @@ num_to_superscript <- function(x) {
return(supx)
}
ordinal <- function(x) {
if (!is.numeric(x) || !is.vector(x) || is_null(x)) stop("x must be a numeric vector.")
if (!is.numeric(x) || !is.vector(x) || is_null(x)) stop("'x' must be a numeric vector.")
if (length(x) > 1) return(vapply(x, ordinal, character(1L)))
else {
x0 <- abs(x)
Expand Down Expand Up @@ -210,14 +210,14 @@ check_if_zero <- function(x) {
abs(x) < tolerance
}
between <- function(x, range, inclusive = TRUE, na.action = FALSE) {
if (!all(is.numeric(x))) stop("x must be a numeric vector.", call. = FALSE)
if (length(range) != 2) stop("range must be of length 2.", call. = FALSE)
if (anyNA(range) || !is.numeric(range)) stop("range must contain numeric entries only.", call. = FALSE)
if (!all(is.numeric(x))) stop("'x' must be a numeric vector.", call. = FALSE)
if (length(range) != 2) stop("'range' must be of length 2.", call. = FALSE)
if (anyNA(range) || !is.numeric(range)) stop("'range' must contain numeric entries only.", call. = FALSE)

if (range[2] < range[1]) range <- c(range[2], range[1])

if (anyNA(x)) {
if (length(na.action) != 1 || !is.atomic(na.action)) stop("na.action must be an atomic vector of length 1.", call. = FALSE)
if (length(na.action) != 1 || !is.atomic(na.action)) stop("'na.action' must be an atomic vector of length 1.", call. = FALSE)
}
if (inclusive) out <- ifelse(is.na(x), na.action, x >= range[1] & x <= range[2])
else out <- ifelse(is.na(x), na.action, x > range[1] & x < range[2])
Expand Down Expand Up @@ -257,11 +257,11 @@ binarize <- function(variable, zero = NULL, one = NULL) {
}
else {
if (one %in% unique.vals) return(setNames(as.integer(variable.numeric == one), names(variable)))
else stop("The argument to \"one\" is not the name of a level of variable.", call. = FALSE)
else stop("The argument to 'one' is not the name of a level of variable.", call. = FALSE)
}
}
else {
if (zero %nin% unique.vals) stop("The argument to \"zero\" is not the name of a level of variable.", call. = FALSE)
if (zero %nin% unique.vals) stop("The argument to 'zero' is not the name of a level of variable.", call. = FALSE)
}

newvar <- setNames(as.integer(variable.numeric != zero), names(variable))
Expand All @@ -275,15 +275,15 @@ center <- function(x, at = NULL, na.rm = TRUE) {
x <- as.matrix.data.frame(x)
type <- "df"
}
if (!is.numeric(x)) stop("x must be numeric.")
else if (is.array(x) && length(dim(x)) > 2) stop("x must be a numeric or matrix-like (not array).")
if (!is.numeric(x)) stop("'x' must be numeric.")
else if (is.array(x) && length(dim(x)) > 2) stop("'x' must be a numeric or matrix-like (not array).")
else if (!is.matrix(x)) {
x <- matrix(x, ncol = 1)
type <- "vec"
}
else type <- "matrix"
if (is_null(at)) at <- colMeans(x, na.rm = na.rm)
else if (length(at) %nin% c(1, ncol(x))) stop("at is not the right length.")
else if (length(at) %nin% c(1, ncol(x))) stop("'at' is not the right length.")
out <- x - matrix(at, byrow = TRUE, ncol = ncol(x), nrow = nrow(x))
if (type == "df") out <- as.data.frame.matrix(out)
else if (type == "vec") out <- drop(out)
Expand All @@ -303,19 +303,19 @@ col.w.v <- function(mat, w = NULL, bin.vars = NULL, na.rm = TRUE) {
if (!is.matrix(mat)) {
if (is.data.frame(mat)) {
if (any(vapply(mat, is_, logical(1L), types = c("factor", "character")))) {
stop("mat must be a numeric matrix.")
stop("'mat' must be a numeric matrix.")
}
else mat <- data.matrix(mat)
}
else if (is.numeric(mat)) {
mat <- matrix(mat, ncol = 1)
}
else stop("mat must be a numeric matrix.")
else stop("'mat' must be a numeric matrix.")
}

if (is_null(bin.vars)) bin.vars <- rep(FALSE, ncol(mat))
else if (length(bin.vars) != ncol(mat) || anyNA(as.logical(bin.vars))) {
stop("bin.vars must be a logical vector with length equal to the number of columns of mat.", call. = FALSE)
stop("'bin.vars' must be a logical vector with length equal to the number of columns of 'mat'.", call. = FALSE)
}
bin.var.present <- any(bin.vars)
non.bin.vars.present <- any(!bin.vars)
Expand Down Expand Up @@ -475,7 +475,7 @@ get.covs.and.treat.from.formula <- function(f, data = NULL, terms = FALSE, sep =

env <- environment(f)

if (!is.formula(f)) stop("f must be a formula.")
if (!is.formula(f)) stop("'f' must be a formula.")

eval.model.matrx <- identical(f, f <- subbars(f))

Expand Down Expand Up @@ -532,7 +532,7 @@ get.covs.and.treat.from.formula <- function(f, data = NULL, terms = FALSE, sep =
}, logical(1L))

if (any(rhs.vars.failed)) {
stop(paste0(c("All variables in formula must be variables in data or objects in the global environment.\nMissing variables: ",
stop(paste0(c("All variables in 'formula' must be variables in 'data' or objects in the global environment.\nMissing variables: ",
paste(rhs.vars.mentioned[rhs.vars.failed], collapse=", "))), call. = FALSE)

}
Expand Down Expand Up @@ -609,7 +609,7 @@ get.covs.and.treat.from.formula <- function(f, data = NULL, terms = FALSE, sep =

if (eval.model.matrx) {
if (s <- !identical(sep, "")) {
if (!is.character(sep) || length(sep) > 1) stop("sep must be a string of length 1.", call. = FALSE)
if (!is.character(sep) || length(sep) > 1) stop("'sep' must be a string of length 1.", call. = FALSE)
original.covs.levels <- make_list(names(covs))
for (i in names(covs)) {
if (is.character(covs[[i]])) covs[[i]] <- factor(covs[[i]])
Expand Down Expand Up @@ -670,115 +670,53 @@ get.treat.type <- function(treat) {
has.treat.type <- function(treat) {
is_not_null(get.treat.type(treat))
}

#Input processing
process.bin.vars <- function(bin.vars, mat) {
if (missing(bin.vars)) bin.vars <- is_binary_col(mat)
else if (is_null(bin.vars)) bin.vars <- rep(FALSE, ncol(mat))
else {
if (is.logical(bin.vars)) {
bin.vars[is.na(bin.vars)] <- FALSE
if (length(bin.vars) != ncol(mat)) stop("If 'bin.vars' is logical, it must have length equal to the number of columns of 'mat'.")
}
else if (is.numeric(bin.vars)) {
bin.vars <- bin.vars[!is.na(bin.vars) & bin.vars != 0]
if (any(bin.vars < 0) && any(bin.vars > 0)) stop("Positive and negative indices cannot be mixed with 'bin.vars'.")
if (any(abs(bin.vars) > ncol(mat))) stop("If 'bin.vars' is numeric, none of its values can exceed the number of columns of 'mat'.")
logical.bin.vars <- rep(any(bin.vars < 0), ncol(mat))
logical.bin.vars[abs(bin.vars)] <- !logical.bin.vars[abs(bin.vars)]
bin.vars <- logical.bin.vars
}
else if (is.character(bin.vars)) {
bin.vars <- bin.vars[!is.na(bin.vars) & bin.vars != ""]
if (is_null(colnames(mat))) stop("If 'bin.vars' is character, 'mat' must have column names.")
if (any(bin.vars %nin% colnames(mat))) stop("If 'bin.vars' is character, all its values must be column names of 'mat'.")
bin.vars <- colnames(mat) %in% bin.vars
}
else stop("'bin.vars' must be a logical, numeric, or character vector.")
}
return(bin.vars)
}
process.s.weights <- function(s.weights, data = NULL) {
#Process s.weights
if (is_not_null(s.weights)) {
if (!(is.character(s.weights) && length(s.weights) == 1) && !is.numeric(s.weights)) {
stop("The argument to s.weights must be a vector or data frame of sampling weights or the (quoted) names of the variable in data that contains sampling weights.", call. = FALSE)
stop("The argument to 's.weights' must be a vector or data frame of sampling weights or the (quoted) names of the variable in 'data' that contains sampling weights.", call. = FALSE)
}
if (is.character(s.weights) && length(s.weights)==1) {
if (is_null(data)) {
stop("s.weights was specified as a string but there was no argument to data.", call. = FALSE)
stop("'s.weights' was specified as a string but there was no argument to 'data'.", call. = FALSE)
}
else if (s.weights %in% names(data)) {
s.weights <- data[[s.weights]]
}
else stop("The name supplied to s.weights is not the name of a variable in data.", call. = FALSE)
else stop("The name supplied to 's.weights' is not the name of a variable in 'data'.", call. = FALSE)
}
}
else s.weights <- NULL
return(s.weights)
}
process.focal.and.estimand <- function(focal, estimand, treat, treat.type, treated = NULL) {
reported.estimand <- estimand

if (!has.treat.type(treat)) treat <- assign.treat.type(treat)
treat.type <- get.treat.type(treat)

#Check focal
if (treat.type == "multinomial") {
unique.treat <- unique(treat, nmax = length(treat)/4)
if (estimand %nin% c("ATT", "ATC") && is_not_null(focal)) {
warning(paste(estimand, "is not compatible with 'focal'. Setting 'estimand' to \"ATT\"."), call. = FALSE)
reported.estimand <- estimand <- "ATT"
}

if (estimand == "ATT") {
if (is_null(focal)) {
if (is_null(treated) || treated %nin% unique.treat) {
stop("When estimand = \"ATT\" for multinomial treatments, an argument must be supplied to 'focal'.", call. = FALSE)
}
focal <- treated
}
}
else if (estimand == "ATC") {
if (is_null(focal)) {
stop("When estimand = \"ATC\" for multinomial treatments, an argument must be supplied to 'focal'.", call. = FALSE)
}
}
}
else if (treat.type == "binary") {
unique.treat <- unique(treat, nmax = 2)
unique.treat.bin <- unique(binarize(treat), nmax = 2)
if (estimand %nin% c("ATT", "ATC") && is_not_null(focal)) {
warning(paste(estimand, "is not compatible with 'focal'. Setting 'estimand' to \"ATT\"."), call. = FALSE)
reported.estimand <- estimand <- "ATT"
}

if (estimand == "ATT") {
if (is_null(focal)) {
if (is_null(treated) || treated %nin% unique.treat) {
if (all(as.character(unique.treat.bin) == as.character(unique.treat))) {
#If is 0/1
treated <- unique.treat[unique.treat.bin == 1]
}
else {
treated <- names(which.min(table(treat))) #Smaller group is treated
message(paste0("Assuming ", word_list(treated, quotes = !is.numeric(treat), is.are = TRUE),
" the treated level. If not, supply an argument to 'focal'."))
}
}
focal <- treated
}
else {
if (is_null(treated) || treated %nin% unique.treat) {
treated <- focal
}
}
}
else if (estimand == "ATC") {
if (is_null(focal)) {
if (is_null(treated) || treated %nin% unique.treat) {

if (all(as.character(unique.treat.bin) == as.character(unique.treat))) {
treated <- unique.treat[unique.treat.bin == 1]
}
else {
treated <- names(which.min(table(treat))) #Smaller group is treated
message(paste0("Assuming ", word_list(unique.treat[unique.treat %nin% treated], quotes = !is.numeric(treat), is.are = TRUE),
" the control level. If not, supply an argument to 'focal'."))
}
}
focal <- unique.treat[unique.treat %nin% treated]
}
else {
if (is_null(treated) || treated %nin% unique.treat) {
treated <- unique.treat[unique.treat %nin% focal]
}
}
estimand <- "ATT"
}
}

if (is_not_null(focal) && (length(focal) > 1L || focal %nin% unique.treat)) {
stop("The argument supplied to 'focal' must be the name of a level of treatment.", call. = FALSE)
}

return(list(focal = as.character(focal),
estimand = estimand,
reported.estimand = reported.estimand,
treated = if (is.factor(treated)) as.character(treated) else treated))
}

#Uniqueness
nunique <- function(x, nmax = NA, na.rm = TRUE) {
Expand All @@ -791,8 +729,8 @@ nunique <- function(x, nmax = NA, na.rm = TRUE) {

}
nunique.gt <- function(x, n, na.rm = TRUE) {
if (missing(n)) stop("n must be supplied.")
if (n < 0) stop("n must be non-negative.")
if (missing(n)) stop("'n' must be supplied.")
if (n < 0) stop("'n' must be non-negative.")
if (is_null(x)) FALSE
else {
if (n == 1) !all_the_same(x, na.rm)
Expand Down Expand Up @@ -848,9 +786,9 @@ make_df <- function(ncol, nrow = 0, types = "numeric") {
colnames(df) <- col_names
rownames(df) <- row_names
if (is_not_null(types)) {
if (length(types) %nin% c(1, ncol)) stop("types must be equal to the number of columns.")
if (length(types) %nin% c(1, ncol)) stop("'types' must be equal to the number of columns.")
if (any(types %nin% c("numeric", "integer", "logical", "character", NA))) {
stop("types must be an acceptable type. For factors, use NA.")
stop("'types' must be an acceptable type. For factors, use NA.")
}
if (length(types) == 1) types <- rep(types, ncol)
for (i in seq_len(ncol)) if (!is.na(types)[i] && types[i] != "numeric") df[[i]] <- get(types[i])(nrow)
Expand Down

0 comments on commit 5f99883

Please sign in to comment.