R/tableContinuous2.R

In johnjosephhorton/JJHmisc: Collection of scripts that I've found useful.

#' Modified version of the reporttools code 
#'
#' @param vars  
#' @return line to be written. 
#' @export

tableContinuous2 <- 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) 
{
    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, only.contents = TRUE,
        ##     type = "latex", hline.after = hlines, size = font.size, caption.placement = "top",
        ##     sanitize.text.function = function(x) {
        ##         x
        ##     }, tabular.environment = tab.env)
        xtab3
    }
    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, only.contents = TRUE,
        ##     type = "latex", hline.after = hlines, size = font.size, caption.placement = "top",
            
        ##     sanitize.text.function = function(x) {
        ##         x
        ##     }, tabular.environment = tab.env)
        xtab1
    }
}