Skip to content

Commit

Permalink
Adjust print.xbal
Browse files Browse the repository at this point in the history 
Fixes a problem from f4408b7 . See also  1f71fc0 , comments to #90.
(While I was at it I adjusted internal variable names, maybe making
it a bit easier to read.)
  • Loading branch information
@benthestatistician
benthestatistician committed Jun 28, 2018
1 parent fcf367f commit 988a5d5
Showing 1 changed file with 53 additions and 56 deletions.
109 changes: 53 additions & 56 deletions R/print.xbal.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -104,7 +104,7 @@ print.xbal <- function (x, which.strata=dimnames(x$results)[["strata"]],
report <- attr(x, "report")
}
x <- subset(x, vars = which.vars, strata = which.strata, stats = which.stats)
theresults <- x$results
results_array <- x$results

# for historical reasons, what the user requests and the column names in the per-variable table are not the same
lookup <- c("std.diffs" = "std.diff", "z.scores" = "z",
Expand All @@ -128,29 +128,29 @@ print.xbal <- function (x, which.strata=dimnames(x$results)[["strata"]],
tmp <- lookup[report[report %in% names(lookup)]]

# likewise, don't grab any columns that aren't there
theresults <- theresults[, tmp[tmp %in% dimnames(theresults)[["stat"]]], , drop = FALSE]
results_array <- results_array[, tmp[tmp %in% dimnames(results_array)[["stat"]]], , drop = FALSE]
}

## Mark the columns that will require by-row sigfig handling
orig_units_columns <- intersect(c("Treatment", "Control", "adj.diff", "pooled.sd"),
dimnames(theresults)[["stat"]])
dimnames(results_array)[["stat"]])

hasP <- "p" %in% dimnames(theresults)[["stat"]]
hasP <- "p" %in% dimnames(results_array)[["stat"]]

if("chisquare.test" %in% report || "all" %in% report) { ##Extract the omnibus chisquared test from the xbal object...
theoverall <- x$overall
} else {
theoverall<-NULL ##..or set it to NULL if it does not exist.
}

if (length(theresults) == 0 && is.null(theoverall)) {
if (length(results_array) == 0 && is.null(theoverall)) {
stop("There is a problem. Probably all of the variables (",
all.vars(formula(x)),
") are constants within strata. Or else there is some other problem, try debug(RItools:::xBalance) to see what might be going on.")
}

if (length(theresults)==0 && !is.null(theoverall)){##The user has requested only the omnibus test and not the tests for the individual variables
theresults<-NULL
if (length(results_array)==0 && !is.null(theoverall)){##The user has requested only the omnibus test and not the tests for the individual variables
results_array<-NULL
thevartab<-NULL
}

Expand All @@ -168,58 +168,55 @@ print.xbal <- function (x, which.strata=dimnames(x$results)[["strata"]],
ftable(data, col.vars=c("strata","stat"),row.vars=c("vars"))
}

if (!is.null(theresults)) {
thevartab <- ftabler(theresults) # we'll update this variable later if we include p-values or significance stars
}

if (show.signif.stars && !show.pvals && !is.null(theresults) && hasP ) {

Signif <- signifier(theresults[,"p",,drop=FALSE])
if (!is.null(results_array)) {
results_array_char <- array(dim = dim(results_array), dimnames=dimnames(results_array))
## next apply rounding to DIGITS sigfigs, by statistic. If there are
## multiple stratifications, then the significant figure position should be set
## consistently across them.
for (rcol in setdiff(dimnames(results_array)[["stat"]], c("p", orig_units_columns)))
{ #i.e. std.diffs and z stats
res <- results_array[,rcol,]
dim(res) <- NULL
res <- round(res,digits=(DIGITS-1))
results_array_char[,rcol,] <- format(res,digits=DIGITS)
}
if ("p" %in% dimnames(results_array)[["stat"]])
{
res <- results_array[,"p",]
dim(res) <- NULL
results_array_char[,"p",] <- format(res, digits=DIGITS)
}
if (!is.null(orig_units_columns))
results_array_char[,orig_units_columns,] <-
original_units_var_formatter(results_array[,orig_units_columns,,drop=FALSE], digits=DIGITS)

##Nicer alignment, but not as nice labels
##junk<-do.call(cbind,lapply(which.strata,function(x){cbind(as.data.frame(theresults[,,x])," "=format(Signif[,,x]))}))
newresults <- array(dim = dim(theresults) + c(0,1,0),
dimnames=list(vars=dimnames(theresults)[["vars"]],
stat=c(dimnames(theresults)[["stat"]],"sig."),
strata=dimnames(theresults)[["strata"]]))
## next apply rounding to DIGITS sigfigs, by statistic. If there are
## multiple stratifications, then the significant figure position should be set
## consistently across them.
for (rcol in setdiff(dimnames(theresults)[["stat"]], c("p", orig_units_columns)))
{ #i.e. std.diffs and z stats
res <- theresults[,rcol,]
dim(res) <- NULL
res <- round(res,digits=(DIGITS-1))
newresults[,rcol,] <- format(res,digits=DIGITS)
}
if ("p" %in% dimnames(theresults)[["stat"]])
{
res <- theresults[,"p",]
dim(res) <- NULL
newresults[,"p",] <- format(res, digits=DIGITS)
}
if (!is.null(orig_units_columns))
newresults[,orig_units_columns,] <-
original_units_var_formatter(theresults[,orig_units_columns,,drop=FALSE], digits=DIGITS)

newresults[dimnames(Signif)[["vars"]], "sig.",dimnames(Signif)[["strata"]]]<-format(Signif)
thevartab <- ftabler(results_array_char) # we'll update this variable later if we include p-values or significance stars
}

if (show.signif.stars && !show.pvals && !is.null(results_array) && hasP )
{
Signif <- signifier(results_array[,"p",,drop=FALSE])
dimnames(Signif)[['stat']] <- 'sig.'
Signif <- format(Signif)
results_array_char <- abind(results_array_char, Signif,
along=2, use.first.dimnames=TRUE)
names(dimnames(results_array_char)) <- names(dimnames(results_array))

if (horizontal){
tmp <- dimnames(newresults)[[2]]
theftab <- ftabler(newresults[, c(tmp[!(tmp == "p")]), , drop=FALSE])
tmp <- dimnames(results_array_char)[[2]]
theftab <- ftabler(results_array_char[, c(tmp[!(tmp == "p")]), , drop=FALSE])

attr(theftab,"col.vars")$stat[attr(theftab,"col.vars")$stat=="sig."] <- ""
if ("z" %in% dimnames(newresults)$stat) {
if ("z" %in% dimnames(results_array_char)$stat) {
attr(theftab,"col.vars")$stat[attr(theftab,"col.vars")$stat=="z"]<-" z "
}

thevartab<-theftab
} else {
tmp <- dimnames(newresults)[[2]]
thevartab <- sapply(dimnames(newresults)[[3]],
tmp <- dimnames(results_array_char)[[2]]
thevartab <- sapply(dimnames(results_array_char)[[3]],
function(s) {
tmpdata <- newresults[, c(tmp[!(tmp == "p")]), s, drop = FALSE]
tmpdata <- results_array_char[, c(tmp[!(tmp == "p")]), s, drop = FALSE]
tmpdn <- dimnames(tmpdata)[1:2]
dim(tmpdata) <- dim(tmpdata)[1:2]
dimnames(tmpdata) <- tmpdn
Expand All @@ -231,27 +228,27 @@ print.xbal <- function (x, which.strata=dimnames(x$results)[["strata"]],
}
}

if (show.pvals && hasP && !is.null(theresults)) {
if (show.pvals && hasP && !is.null(results_array)) {
if (horizontal) {
theftab <- ftabler(theresults)
theftab <- ftabler(results_array_char)
thevartab <- theftab
} else {
thevartab <- sapply(
dimnames(theresults)[[3]],
dimnames(results_array_char)[[3]],
function(x) {
as.data.frame(theresults[,,x])
as.data.frame(results_array_char[,,x])
},
simplify=FALSE, USE.NAMES=TRUE
)
}
}

##if(show.pvals&!("p"%in% dimnames(theresults)[["stat"]])& !is.null(theresults)) {
##if(show.pvals&!("p"%in% dimnames(results_array)[["stat"]])& !is.null(results_array)) {
## stop("You need to request p-values when calling xBalance.")
##} ##irrelevant now.

if (!is.null(theoverall)) {
nc <- length(theresults)/2
nc <- length(results_array)/2
latex.annotation <- NULL
## paste("\\\\ \\hline Overall",
## paste("\\multicolumn{",nc,"}{c}{",preSig,"}"),
Expand All @@ -270,15 +267,15 @@ print.xbal <- function (x, which.strata=dimnames(x$results)[["strata"]],

if (printme) {
## RItools:::print.ftable(thevartab,justify.labels="center",justify.data="right") ##doesn't seem to help the alignment problem
if (!is.null(theresults)){ print(thevartab) }
if (!is.null(results_array)){ print(thevartab) }
if (!is.null(theoverall) && print.overall) {
cat("---Overall Test---\n")
print(theoveralltab, quote=FALSE)
if (show.signif.stars && !show.pvals && hasP) {
if (!is.null(theresults)) {
if (!is.null(results_array)) {
thelegend<-attr(Signif, "legend") ##if we are showing thevartab use the legend from that object
}
if (is.null(theresults) && !is.null(theoverall)) {
if (is.null(results_array) && !is.null(theoverall)) {
thelegend<-attr(ChiSignif,"legend") ##use legend from the overall object if only showing that one
}
cat("---\nSignif. codes: ", thelegend, "\n")
Expand Down

0 comments on commit 988a5d5

Please sign in to comment.