Last active
December 17, 2015 23:19
-
-
Save johnjosephhorton/5688741 to your computer and use it in GitHub Desktop.
This is tableContinuous from reporttools - I'd like it to include the ability to pass a caption placement parameter to the function.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
tableContinuous <- function (vars, weights = NA, subset = NA, group = NA, stats = c("n", | |
"min", "q1", "median", "mean", "q3", "max", "s", "iqr", "na"), | |
prec = 1, col.tit = NA, col.tit.font = c("bf", "", "sf", | |
"it", "rm"), print.pval = c("none", "anova", "kruskal"), | |
pval.bound = 10^-4, declare.zero = 10^-10, cap = "", lab = "", | |
font.size = "footnotesize", longtable = TRUE, disp.cols = NA, | |
nams = NA, caption.placement = "bottom") | |
{ | |
print.pval <- match.arg(print.pval) | |
if (identical(disp.cols, NA) == FALSE) { | |
stats <- disp.cols | |
} | |
if (is.data.frame(vars) == TRUE) { | |
tmp <- vars | |
vars <- list() | |
for (i in 1:ncol(tmp)) { | |
vars[[i]] <- tmp[, i] | |
} | |
nams <- colnames(tmp) | |
} | |
n.var <- length(nams) | |
if (identical(subset, NA) == FALSE) { | |
if (identical(group, NA) == FALSE) { | |
group <- group[subset] | |
} | |
if (identical(weights, NA) == FALSE) { | |
weights <- weights[subset] | |
} | |
for (i in 1:n.var) { | |
vars[[i]] <- vars[[i]][subset] | |
} | |
} | |
for (i in 1:length(nams)) { | |
nams[i] <- gsub("_", "\\\\_", as.character(nams[i])) | |
} | |
if (identical(col.tit, NA) == TRUE) { | |
col.tit.font <- match.arg(col.tit.font) | |
fonts <- getFonts(col.tit.font) | |
col.tit <- c(fonts$text("Variable"), fonts$text("Levels"), | |
fonts$math("n"), fonts$text("Min"), fonts$math("q_1"), | |
fonts$math("\\widetilde{x}"), fonts$math("\\bar{x}"), | |
fonts$math("q_3"), fonts$text("Max"), fonts$math("s"), | |
fonts$text("IQR"), fonts$text("\\#NA")) | |
} | |
if (identical(weights, NA) == TRUE) { | |
weights2 <- 1 | |
} | |
if (identical(weights, NA) == FALSE) { | |
weights2 <- weights | |
} | |
n.levels <- 1 | |
if (identical(group, NA) == FALSE) { | |
group <- factor(group, exclude = NULL) | |
group <- as.factor(group) | |
n.levels <- length(levels(group)) | |
group <- rep(group, times = weights2) | |
} | |
for (i in 1:n.var) { | |
vars[[i]] <- rep(vars[[i]], times = weights2) | |
} | |
ncols <- length(stats) | |
s1 <- unlist(lapply(stats, is.character)) | |
s1 <- (1:ncols)[s1] | |
s2 <- unlist(lapply(stats, is.function)) | |
s2 <- (1:ncols)[s2] | |
out <- matrix(NA, ncol = 12, nrow = (n.levels + 1) * n.var) | |
out <- data.frame(out) | |
out.fct <- matrix(NA, ncol = length(s2), nrow = (n.levels + | |
1) * n.var) | |
out.fct <- data.frame(out.fct) | |
for (i in 1:n.var) { | |
ind <- (i - 1) * (n.levels + 1) + 1:(n.levels + 1) | |
splits <- list(vars[[i]]) | |
if (identical(group, NA) == FALSE) { | |
splits <- split(vars[[i]], group) | |
} | |
for (j in 1:n.levels) { | |
tmp <- as.vector(splits[[j]]) | |
if (sum(is.na(tmp) == FALSE) != 0) { | |
out[ind[j], 3] <- sum(is.na(tmp) == FALSE) | |
out[ind[j], 4] <- min(tmp, na.rm = TRUE) | |
out[ind[j], 5] <- quantile(tmp, 0.25, na.rm = TRUE) | |
out[ind[j], 6] <- median(tmp, na.rm = TRUE) | |
out[ind[j], 7] <- mean(tmp, na.rm = TRUE) | |
out[ind[j], 8] <- quantile(tmp, 0.75, na.rm = TRUE) | |
out[ind[j], 9] <- max(tmp, na.rm = TRUE) | |
out[ind[j], 10] <- sd(tmp, na.rm = TRUE) | |
out[ind[j], 11] <- out[ind[j], 8] - out[ind[j], | |
5] | |
out[ind[j], 12] <- sum(is.na(tmp) == TRUE) | |
if (length(s2) > 0) { | |
for (f in 1:length(s2)) { | |
out.fct[ind[j], f] <- stats[[s2[f]]](tmp[is.na(tmp) == | |
FALSE]) | |
} | |
} | |
} | |
} | |
vi <- as.vector(vars[[i]]) | |
out[max(ind), 3] <- sum(is.na(vi) == FALSE) | |
out[max(ind), 4] <- min(vi, na.rm = TRUE) | |
out[max(ind), 5] <- quantile(vi, 0.25, na.rm = TRUE) | |
out[max(ind), 6] <- median(vi, na.rm = TRUE) | |
out[max(ind), 7] <- mean(vi, na.rm = TRUE) | |
out[max(ind), 8] <- quantile(vi, 0.75, na.rm = TRUE) | |
out[max(ind), 9] <- max(vi, na.rm = TRUE) | |
out[max(ind), 10] <- sd(vi, na.rm = TRUE) | |
out[max(ind), 11] <- out[max(ind), 8] - out[max(ind), | |
5] | |
out[max(ind), 12] <- sum(is.na(vi) == TRUE) | |
out[, 3:12][abs(out[, 3:12]) <= declare.zero] <- 0 | |
if (length(s2) > 0) { | |
for (f in 1:length(s2)) { | |
out.fct[max(ind), f] <- stats[[s2[f]]](vi[is.na(vi) == | |
FALSE]) | |
} | |
out.fct[abs(out.fct) <= declare.zero] <- 0 | |
} | |
v1 <- vars[[i]] | |
g1 <- as.character(group) | |
indNA <- (is.na(g1) == FALSE) & (g1 != "NA") & (is.na(v1) == | |
FALSE) & (v1 != "NA") | |
v2 <- v1[indNA] | |
g2 <- g1[indNA] | |
ind1 <- length(unique(g2)) > 1 | |
ind2 <- print.pval %in% c("anova", "kruskal") | |
ind3 <- 1 | |
if (ind1 >= 1) { | |
splits2 <- split(v2, g2) | |
for (s in 1:length(splits2)) { | |
if (sum(is.na(splits2[[1]]) == TRUE) == length(splits2[[1]])) { | |
ind3 <- 0 | |
} | |
} | |
} | |
if (ind1 * ind2 * ind3 == 1) { | |
g2 <- as.factor(g2) | |
if (print.pval == "anova") { | |
pval <- anova(lm(v2 ~ g2))$"Pr(>F)"[1] | |
} | |
if (print.pval == "kruskal") { | |
pval <- kruskal.test(v2 ~ g2)$p.value | |
} | |
out[(i - 1) * (n.levels + 1) + n.levels + 1, 1] <- paste("p", | |
formatPval(pval, includeEquality = TRUE, eps = pval.bound)) | |
} | |
} | |
dc <- c("n", "min", "q1", "median", "mean", "q3", "max", | |
"s", "iqr", "na") | |
stats.num <- pmatch(stats[s1], dc) | |
align.stats <- "" | |
stats2 <- c(2 + stats.num) | |
out2 <- matrix(NA, ncol = 2 + length(s1) + length(s2), nrow = (n.levels + | |
1) * n.var) | |
out2 <- data.frame(out2) | |
out2[, c(1, 2, 2 + s1)] <- out[, c(1, 2, stats2)] | |
out2[, 2 + s2] <- out.fct | |
out2[((1:n.var) - 1) * (n.levels + 1) + 1, 1] <- nams | |
dimnames(out2)[[2]][c(1:2, 2 + s1)] <- col.tit[c(1:2, stats2)] | |
if (length(s2) > 0) { | |
dimnames(out2)[[2]][2 + s2] <- names(stats)[names(stats) != | |
""] | |
} | |
for (i in 1:ncols) { | |
align.stats <- paste(align.stats, "r", sep = "") | |
} | |
if (n.levels == 1) { | |
prec <- c(rep(0, 1), rep(prec, ncols)) | |
ali <- "ll" | |
out2 <- out2[, -2] | |
} | |
if (n.levels > 1) { | |
prec <- c(rep(0, 2), rep(prec, ncols)) | |
ali <- "lll" | |
} | |
for (c in 2:ncol(out2)) { | |
if ((all(out2[, c] == round(out2[, c]), na.rm = TRUE) == | |
TRUE) & (all(is.na(out2[, c])) == FALSE)) { | |
out2[, c] <- format(out2[, c], nsmall = 0) | |
} | |
else { | |
out2[, c] <- format(round(out2[, c], prec[c]), nsmall = prec[c]) | |
} | |
} | |
tmp <- cumsum(rep(n.levels, n.var) + 1) | |
tab.env <- "longtable" | |
float <- FALSE | |
if (identical(longtable, FALSE)) { | |
tab.env <- "tabular" | |
float <- TRUE | |
} | |
if (n.levels == 1) { | |
out3 <- out2[(1:n.var - 1) * 2 + 1, ] | |
hlines <- 0 | |
xtab3 <- xtable::xtable(out3, align = paste(ali, align.stats, | |
sep = ""), caption = cap, label = lab) | |
xtab4 <- print(xtab3, include.rownames = FALSE, floating = float, | |
type = "latex", hline.after = hlines, size = font.size, caption.placement = caption.placement, | |
sanitize.text.function = function(x) { | |
x | |
}, tabular.environment = tab.env) | |
} | |
if (n.levels > 1) { | |
out2[, 2] <- rep(c(levels(group), "all"), times = n.var) | |
hlines <- sort(c(0, tmp - 1, tmp)) | |
xtab1 <- xtable::xtable(out2, align = paste(ali, align.stats, | |
sep = ""), caption = cap, label = lab) | |
xtab2 <- print(xtab1, include.rownames = FALSE, floating = float, | |
type = "latex", hline.after = hlines, size = font.size, caption.placement = caption.placement, | |
sanitize.text.function = function(x) { | |
x | |
}, tabular.environment = tab.env) | |
} | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment