R/bodyBuildeR.R

In enaY15/TabulationAutomation: Auomated analysis and tabulation of results

#' Table Body Builder
#'
#' @param matListoLists if list (elements = outcomes) of sublists (elements = models) of results
#' @param matList if list (elements = models) of matrices (all same outcome)
#' @param mat Name of result summary matrix to look for in environment...Format: <outcome>_<analysis>_<model>
#' @param matModelName Predictor model names; separates sets of predictors, which are in rows, if multiple sets in same table
#' @param multiOutcome Multiple outcomes in same table? TRUE/FALSE
#' @param outcomeNames Names of outcomes for table column names
#' @param stars Signficance stars in place of p-values? TRUE/FALSE
#'
#' @return
#' @export
bodyBuildeR <- function(matListoLists = NULL,
                        matList = NULL, # if list (elements = models) of matrices (all same outcome)
                        mat = NULL,
                        analysis = 'cfa', multiOutcome = NULL, outcomeNames = NULL, stars = NULL) {

  if (multiOutcome == FALSE) matModelNames <- names(matList)
  if (multiOutcome == TRUE) matModelNames <- names(matListoLists[[1]]) # takes names of first sublist elements
    # N.B. (assumes all outcomes/elements of highest level listolists have same models as sublists)

  require(SGP)

  starsFX <- function(mat) {

    if (is.null(model)) model <- 'Estimate' # if unspecified, column name with coefficient should be called "Estimate" instead of the model name
    tmp <- as.matrix(mat)
    dimnames(tmp)[dimnames(tmp)[[2]] == 'Pr(>|t|)' || dimnames(tmp)[[2]] == 'Pr(>|z|)'] <- 'p.val' # Change p value name so can more easily index
    tmp <- data.frame(tmp, stringsAsFactors=FALSE)
    tmp$p.val <- as.numeric(as.character(tmp[, which(colnames(tmp) == 'p.val')]))
    tmp$Estimate <- format(round(as.numeric(as.character(tmp$Estimate)), digits = 2), nsmall = 2)
    tmp$p.val <- ifelse((tmp$p.val > 0.05), '',
                        ifelse((tmp$p.val < 0.05 & tmp$p.val >= 0.01), '*',
                               ifelse((tmp$p.val < 0.01 & tmp$p.val >= 0.001), '**', '***')))
    significantRows <- which(tmp$p.val == '**' | tmp$p.val == '***')
    significantRows <- significantRows[significantRows != 1]
    negativeRows <- grep(tmp[, 'Estimate'], pattern = "-.*")
    negSig <- significantRows[significantRows %in% negativeRows]
    posSig <- significantRows[significantRows %in% negativeRows == FALSE]

  ### Colors :) for significant, positive, negative, or ns
    tmp[posSig, 'Estimate'] <- paste0('\\textcolor{ForestGreen}{\\textbf{', tmp[posSig, 'Estimate'], '}}')
    tmp[negSig, 'Estimate'] <- paste0('\\textcolor{Red}{\\textbf{', tmp[negSig, 'Estimate'], '}}')


    tmp <- paste0(tmp[, 'Estimate'], tmp[, 'p.val'])
    #tmp <- as.matrix(tmp)
    #colnames(tmp) <- colnames(mat)[dimnames(tmp)[[2]] != 'Pr(>|t|)' || dimnames(tmp)[[2]] != 'Pr(>|z|)']
    return(tmp)

  }


## Prepare DFs for conversion to syntax

  rowBound <- vector(mode = 'list') # initialize empty list

  for (dv in 1:length(matListoLists)) {

    matList <- matListoLists[[dv]]
    if (is.null(outcomeNames)) outcomeNames <- names(matList) # "pretty" outcome names

    for (m in 1:length(matList)) {
      mat <- data.frame(matList[[m]], stringsAsFactors=FALSE)
      if (stars == TRUE) {
        mat$Estimate <- starsFX(mat) # apply stars function if wanted
        mat <- subset(mat, select = -c(p.val))
      }
      # dimnames(matList[[m]])[2][dimnames(matList[[m]])[2] == 'Estimate'] <- names(matListoLists)[dv]
      # dimnames(matList[[m]])[2][dimnames(matList[[m]])[2] == 'Predictors'] <- names(matListoLists[[dv]])[m]
      colnames(mat)[colnames(mat) == 'Estimate'] <- outcomeNames[dv]
      colnames(mat)[colnames(mat) == 'Predictors'] <- names(matListoLists[[dv]])[m]
      matList[[m]] <- mat
    }

    matListoLists[[dv]] <- matList
    # rowBoundIter <- gtools::smartbind(list = matList)
    # rowBound <- lapply(rowBound, rowBoundIter)

  }
  options(browser())

  for (m in 1:length())

    tableCols <- colnames(matList[[1]])
    capwords <- function(s, strict = FALSE) {
      cap <- function(s) paste(toupper(substring(s, 1, 1)), {s <- substring(s, 2); if(strict) tolower(s) else s}, sep = "", collapse = " " )
      sapply(strsplit(s, split = " "), cap, USE.NAMES = !is.null(names(s)))
    }
    tableCols <- capwords(tableCols)

    syntax <- c(paste0(tableCols, collapse = ' & '), ' \\\\', ' \\midrule
                ', '')

  #gsub(x = syntax, pattern = 'Std. Error', replacement = 'Standard Error')


# ------------------------------------------------- #
# ------------------------------------------------- #

#### Make Rules for Replacing Predictor Name Abbreviations, etc. #####

  rownames(mat) <- predictors
  body <- rep(NA, dim(mat)[1])
  for (row in 1:dim(mat)[1]) {
    body[row] <- paste0(mat[row, 1:dim(mat)[2]], collapse = ' & ')
    body[row] <- paste0(dimnames(mat)[[1]][row], ' & ', body[row])
    body[row] <- sub(x = body[row], pattern = 'NEGAFF', replacement = 'NEGATIVE AFFECT')
  }

# ------------------------------------------------- #
# ------------------------------------------------- #

##### Create Body Syntax
  body <- paste0('
                 ', body[1:dim(mat)[1]], sep = ' \\\\ ')
  body <- c(body, ' \\midrule
            ')

  if (stars == FALSE) {
    testStats <- c(dimnames(mat[[m]])[2])[[1]] # e.g. Estimate, Std. Error, Pr(>|t|)
    colNames <- NULL
    for (m in 1:length(mat)) colNames <- c(colNames, paste(outcomeNames[m], testStats)) # make outcome-specific column names (e.g. 'General Health Estimate')
    cols <- 0
    for (m in 1:length(mat)) cols <- cols + dim(mat[[m]])[2] # add column numbers of matrix 'm' to running total of column numbers
  } else {
    colNames <- outcomeNames
    cols <- length(outcomeNames)
  }

    #columnHead <- paste0(dimnames(mat)[[2]], collapse = ' & ')

    matModelName <- deparse(substitute(mat))
    matModelName <- sub(pattern = '.*_', x = matModelName, replacement = '')
    matModelName <- paste0(capitalize(matModelName), ' Model')
    matModelName <- paste0('\\textbf{', matModelName, '}')
    tableCols <- c(matModelName, dimnames(mat)[[2]])

    syntax <- c(paste0(tableCols, collapse = ' & '), ' \\\\', ' \\midrule
              ', '')

    ## Body
    body <- rep(NA, dim(mat)[[1]])
    for (row in 1:dim(mat)[[1]]) {
      body[row] <- paste0(mat[row, 1:dim(mat)[[2]]], collapse = ' & ')
      body[row] <- paste0(dimnames(mat)[[1]][row], ' & ', body[row])
    }
    body <- paste0('
                      ', body[1:dim(mat)[1]], sep = ' \\\\ ')
    body <- c(body, ' \\midrule
      ')

    cat(syntax, body)

}