R/tests.R

In desctable: Produce Descriptive and Comparative Tables Easily

#' Transform any test function into a valid test function for the table
#'
#' Transform a function into a valid test function for the table
#' Applying the function on a numerical vector should return one value
#' Applying the function on a factor should return nlevels + 1 value, or one value per factor level
#' @param x A vector
#' @param f The function to try to apply, or a formula combining two functions
#' @param group Grouping factor
#' @return The results for the function applied on the vector, compatible with the format of the result table
#' @keywords internal
testify <- function(x, f, group) {
  # Extract the name of the function
  f %>%
    deparse() %>%
    Reduce(f = paste0) %>%
    substring(2) -> fun

  # If eval(f[[2]]) throws an error, then we may be in an rlang-formula
  tryCatch(f <- eval(f[[2]]),
           error = function(e) {f <<- rlang::as_function(f)})

  # Try the function
  p <- tryCatch(f(x ~ group)$p.value[1],
                error = function(e) {message(e);NaN})

  # Return the correct number of rows depending on the variable type
  if (is.factor(x)) data.frame(p = c(p, rep(NA, nlevels(x))),
                               test = c(fun, rep(NA, nlevels(x))),
                               row.names = NULL, check.names = F, stringsAsFactors = F)
  else              data.frame(p = p,
                               test = fun,
                               row.names = NULL, check.names = F, stringsAsFactors = F)
}


#' Function to choose a statistical test
#'
#' This function takes a variable and a grouping variable as arguments, and returns a statistcal test to use, expressed as a single-term formula.
#'
#' This function uses appropriate non-parametric tests depending on the number of levels (wilcoxon.test for two levels
#' and kruskal.test for more), and fisher.test with fallback on chisq.test on error for factors.
#'
#' @param var The variable to test
#' @param grp The variable for the groups
#' @return A statistical test function
#' @export
tests_auto <- function(var, grp) {
  grp <- factor(grp)

  if (nlevels(grp) < 2)
    ~no.test
  else if (is.factor(var)) {
    if (tryCatch(is.numeric(fisher.test(var ~ grp)$p.value), error = function(e) F))
      ~fisher.test
    else
      ~chisq.test
  } else if (nlevels(grp) == 2)
    ~wilcox.test
  else
    ~kruskal.test
}