R/pilltabs.R

Defines functions knit_print.pilltabs print.pilltabs pilltabs

Documented in knit_print.pilltabs pilltabs print.pilltabs

#' Given a cross-table, outputs HTML code to display several views of with a tabbed interface
#'
#' Given a two dimensions contingency tables, this function outputs HTML code to display,
#' within a dynamic tabbed interface, the count, line row percentages, column percentages and
#' chi-squared residuals tables.
#'
#' @param tab a two dimensions table object
#' @param count wether or not to the display the count table
#' @param rows wether or not to the display the row percentages table
#' @param cols wether or not to the display the column percentages table
#' @param chisq wether or not to the display the table chi-squared test results
#' @param resid wether or not to the display the chi-squared residuals table
#' @param row.names wether 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.
#' @author Julien Barnier <[email protected]@ens-lyon.fr>
#' @examples
#' 
#' data(airquality)
#' tab <- table(airquality$Month, airquality$Ozone > 25)
#' pilltabs(tab)
#' 
#' @import knitr
#' @importFrom questionr cprop rprop chisq.residuals
#' @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 function for pilltabs
#' 
#' Not to be used directly
#' 
#' @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")
  }
}

#' knitr printing function for pilltabs
#' 
#' Not to be used directly
#' 
#' @param res data to be printed, generated by \code{\link{pilltabs}}
#' @param ... arguments passed to other methods
#' @import knitr
#' @importFrom stats runif
#' @export
knit_print.pilltabs <- function(res, ...) {
  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(res[["count"]]))
      result <- paste0(result, '<li class="active"><a href="#dyntab-count', id,'" data-toggle="pill">Count</a></li>\n')
    if (!is.null(res[["rows"]]))
      result <- paste0(result, '<li><a href="#dyntab-rows', id,'" data-toggle="pill">Rows %</a></li>\n')
    if (!is.null(res[["cols"]]))
      result <- paste0(result, '<li><a href="#dyntab-columns', id,'" data-toggle="pill">Columns %</a></li>\n')
    if (!is.null(res[["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(res[["count"]]))
      result <- paste0(result,
                       '  <div class="tab-pane dyntab active" id="dyntab-count', id,'">\n\n\n',
                       paste(res[["count"]], collapse = "\n"),
                       '\n\n\n  </div>\n')
    if (!is.null(res[["rows"]]))    
      result <- paste0(result,
                       '  <div class="tab-pane dyntab" id="dyntab-rows', id,'">\n\n\n',
                       paste(res[["rows"]], collapse = "\n"),
                       '\n\n\n  </div>\n')
    if (!is.null(res[["cols"]]))    
      result <- paste0(result,
                       '  <div class="tab-pane dyntab" id="dyntab-columns', id,'">\n\n\n',
                       paste(res[["cols"]], collapse = "\n"),
                       '\n\n\n  </div>\n', sep = "\n")
    if (!is.null(res[["resid"]]))    
      result <- paste0(result,
                       '  <div class="tab-pane dyntab-residuals" id="dyntab-residuals', id,'">\n\n\n',
                       paste(res[["resid"]], collapse = "\n"),
                       '\n\n\n  </div>\n', sep = "\n")
    result <- paste0(result,
                     '</div>', sep = "\n")
    if (!is.null(res[["chisq"]])) {
      result <- paste0(result,
                       '<p class="chisq-results">', res[["chisq"]],'</p>')
    }
  }
  else {
    if (!is.null(res[["count"]])) {
      result <- paste0(result, "\n\nCount :\n\n", paste(res[["count"]], collapse = "\n"))
    }
    if (!is.null(res[["rows"]])) {
      result <- paste0(result, "\n\nRows percentage :\n\n", paste(res[["rows"]], collapse = "\n"))
    }
    if (!is.null(res[["cols"]])) {
      result <- paste0(result, "\n\nColumns percentage :\n\n", paste(res[["cols"]], collapse = "\n"))
    }
    if (!is.null(res[["resid"]])) {
      result <- paste0(result, "\n\nChi-squared residuals :\n\n", paste(res[["resid"]], collapse = "\n"))
    }
    if (!is.null(res[["chisq"]])) {
      result <- paste0(result, "\n\n", res[["chisq"]])
    }
  }
  
  asis_output(result)
}

Try the rmdformats package in your browser

Any scripts or data that you put into this service are public.

rmdformats documentation built on May 30, 2017, 7:27 a.m.