R/pilltabs.R

In juba/rmdformats: HTML Output Formats and Templates for 'rmarkdown' Documents

#' Given a cross-table, outputs HTML code to display several views of with a tabbed interface
#'
#' Given a two dimensions contingency table, this function outputs HTML code to display,
#' within a dynamic tabbed interface, the count, row percentages, column percentages and
#' chi-squared residuals tables.
#'
#' @param tab a two dimensions table object
#' @param count whether or not to display the count table
#' @param rows whether or not to display the row percentages table
#' @param cols whether or not to display the column percentages table
#' @param chisq whether or not to display the table chi-squared test results
#' @param resid whether or not to display the chi-squared residuals table
#' @param row.names whether or not to display the table row names
#' @details
#' The function is intended to be called inside an rmarkdown document.
#' @return
#' No value is returned.
#' @examples
#'
#' data(airquality)
#' tab <- table(airquality$Month, airquality$Ozone > 25)
#' pilltabs(tab)
#'
#' @import knitr
#' @importFrom stats chisq.test
#' @export


pilltabs <- function(tab, count = TRUE, rows = TRUE, cols = TRUE, chisq = TRUE, resid = TRUE, row.names = TRUE) {

  if (!requireNamespace("questionr", quietly = TRUE))
    stop("the questionr package is needed for the pilltabs() function to work. Please install it.",
         call. = FALSE)

    res <- list()

    if (count) res[["count"]] <- kable(tab, output = FALSE, row.names = row.names)
    if (rows)  res[["rows"]] <- kable(round(questionr::rprop(tab, n = TRUE),1), output = FALSE, row.names = row.names)
    if (cols)  res[["cols"]] <- kable(round(questionr::cprop(tab, n = TRUE),1), output = FALSE, row.names = row.names)
    if (resid) res[["resid"]] <- kable(round(questionr::chisq.residuals(tab),2), output = FALSE, row.names = row.names)
    if (chisq) {
      test <- stats::chisq.test(tab)
      res[["chisq"]] <- paste0('X-squared = ', round(test$statistic, 4),
                               ', df = ', test$parameter,
                               ', p = ', format.pval(test$p.value, digits = 4))
    }
    class(res) <- "pilltabs"
    res
}


#' Printing functions for pilltabs
#'
#' Not to be used directly
#'
#' @rdname pilltabs_print
#' @param x data to be printed, generated by \code{\link{pilltabs}}
#' @param ... arguments passed to other methods
#' @export
print.pilltabs <- function(x, ...) {
  if (!is.null(x[["count"]])) {
    cat("\n--- COUNT ---\n\n")
    cat(x[["count"]], sep = "\n")
  }
  if (!is.null(x[["rows"]])) {
    cat("\n--- ROWS % ---\n\n")
    cat(x[["rows"]], sep = "\n")
  }
  if (!is.null(x[["cols"]])) {
    cat("\n--- COLS % ---\n\n")
    cat(x[["cols"]], sep = "\n")
  }
  if (!is.null(x[["resid"]])) {
    cat("\n--- CHI2 RESIDUALS ---\n\n")
    cat(x[["resid"]], sep = "\n")
  }
  if (!is.null(x[["chisq"]])) {
    cat("\n\n",x[["chisq"]],"\n\n")
  }
}

#' @rdname pilltabs_print
#' @import knitr
#' @importFrom stats runif
#' @export
knit_print.pilltabs <- function(x, ...) {
  result <- ""
  if (knitr::opts_knit$get("rmarkdown.pandoc.to") == "html") {
    ## Generating unique div ids
    id <- round(stats::runif(1) * 10e10)
    result <- paste0(result, '<ul class="nav nav-pills nav-pilltabs">\n')
    if (!is.null(x[["count"]]))
      result <- paste0(result, '<li class="active"><a href="#dyntab-count', id,'" data-toggle="pill">Count</a></li>\n')
    if (!is.null(x[["rows"]]))
      result <- paste0(result, '<li><a href="#dyntab-rows', id,'" data-toggle="pill">Rows %</a></li>\n')
    if (!is.null(x[["cols"]]))
      result <- paste0(result, '<li><a href="#dyntab-columns', id,'" data-toggle="pill">Columns %</a></li>\n')
    if (!is.null(x[["resid"]]))
      result <- paste0(result, '<li><a href="#dyntab-residuals', id,'" data-toggle="pill">Residuals</a></li>\n')
    result <- paste0(result, '</ul>\n')
    result <- paste0(result, '<div class="tab-content">\n')
    if (!is.null(x[["count"]]))
      result <- paste0(result,
                       '  <div class="tab-pane dyntab active" id="dyntab-count', id,'">\n\n\n',
                       paste(x[["count"]], collapse = "\n"),
                       '\n\n\n  </div>\n')
    if (!is.null(x[["rows"]]))
      result <- paste0(result,
                       '  <div class="tab-pane dyntab" id="dyntab-rows', id,'">\n\n\n',
                       paste(x[["rows"]], collapse = "\n"),
                       '\n\n\n  </div>\n')
    if (!is.null(x[["cols"]]))
      result <- paste0(result,
                       '  <div class="tab-pane dyntab" id="dyntab-columns', id,'">\n\n\n',
                       paste(x[["cols"]], collapse = "\n"),
                       '\n\n\n  </div>\n', sep = "\n")
    if (!is.null(x[["resid"]]))
      result <- paste0(result,
                       '  <div class="tab-pane dyntab-residuals" id="dyntab-residuals', id,'">\n\n\n',
                       paste(x[["resid"]], collapse = "\n"),
                       '\n\n\n  </div>\n', sep = "\n")
    result <- paste0(result,
                     '</div>', sep = "\n")
    if (!is.null(x[["chisq"]])) {
      result <- paste0(result,
                       '<p class="chisq-results">', x[["chisq"]],'</p>')
    }
  }
  else {
    if (!is.null(x[["count"]])) {
      result <- paste0(result, "\n\nCount :\n\n", paste(x[["count"]], collapse = "\n"))
    }
    if (!is.null(x[["rows"]])) {
      result <- paste0(result, "\n\nRows percentage :\n\n", paste(x[["rows"]], collapse = "\n"))
    }
    if (!is.null(x[["cols"]])) {
      result <- paste0(result, "\n\nColumns percentage :\n\n", paste(x[["cols"]], collapse = "\n"))
    }
    if (!is.null(x[["resid"]])) {
      result <- paste0(result, "\n\nChi-squared residuals :\n\n", paste(x[["resid"]], collapse = "\n"))
    }
    if (!is.null(x[["chisq"]])) {
      result <- paste0(result, "\n\n", x[["chisq"]])
    }
  }

  asis_output(result)
}