R/test_terms.R

In singmann/monet: Interface for Testing Model Terms via Nested Models

#' Testing Model Terms via Nested Models
#'
#' Generic interfaces that allows Type III tests of model terms (i.e., main
#'   effects and interactions) via nested model comparisons using a
#'   user-supplied estimation/fitting function and user-supplied function for
#'   comparing two models. The default function for testing model terms is
#'   \code{\link{anova}} which returns likelihood-ratio tests.
#' @inheritParams nested_model_formulas
#' @param fit_fun Fitting/estimation function. For example, \code{lm}, \code{lmer}, ...
#' @param fit_arg \code{list} of additional argments passed to \code{fit_fun}.
#' @param test_fun Function comparing two models. Needs to return a
#'   \code{data.frame} with one row and the last two columns
#'   need to be the test statistics (e.g., \code{F}, \code{Chisq}) and the
#'   corresponding p-value (e.g., \code{Pr(>F)}, \code{Pr(>Chisq)}). Default is
#'   \code{\link{anova_df}} which is a wrapper for the generic \code{anova}
#'   function that autodetects relevant columns.
#' @param test_arg additional argument passed to \code{test_fun}. See examples
#'   for how to use it with the default \code{test_fun}.
#'
#' @example examples/examples.test_terms.R
#' @export
test_terms <- function(formula, data, extra_formula,
                       fit_fun, fit_arg = list(),
                       test_fun = anova_df, test_arg = list(),
                       # rev_test_order = FALSE,
                       type = 3,
                       test_intercept = FALSE,
                       na.action) {

  mc <- match.call()
  if (type == 3) type <- "III"

  prep_formulas <- nested_model_formulas(formula = formula,
                                         data = data,
                                         extra_formula = extra_formula,
                                         type = type,
                                         test_intercept = test_intercept,
                                         na.action = na.action)

  fit_fun_tmp <- function(x) {
    do.call(fit_fun, args = c(formula = x,
                              data = list(prep_formulas$data),
                              fit_arg))
  }
  all_fit <- lapply(prep_formulas$formulas, fit_fun_tmp)

  print_message <- TRUE
  test_fun_tmp <- function(x) {
    do.call(test_fun, args = c(object = list(x), list(all_fit[[1]]),
                               test_arg))
  }
  # if (rev_test_order) {
  #   test_fun_tmp <- function(x) {
  #     do.call(test_fun, args = c(object = list(x), list(all_fit[[1]]),
  #                                test_arg))
  #   }
  # } else {
  #   test_fun_tmp <- function(x) {
  #     do.call(test_fun, args = c(object = list(all_fit[[1]]), list(x),
  #                                test_arg))
  #   }
  # }
  anova_table <- do.call("rbind", lapply(all_fit[-1], test_fun_tmp))



  ## prepare output:
  class(anova_table) <- c("anova", "data.frame")
  attr(anova_table, "heading") <- c(
    paste0(deparse(mc[["fit_fun"]]),
           " Anova Table (Type ", type , " tests)\n"),
    paste0("Model: ", deparse(prep_formulas$formulas[[1]])),
    paste0("Data: " , deparse(mc[["data"]]))
    # paste0("Df full model: ", )
    )
  attr(anova_table, "sig_symbols") <- c(" +", " *", " **", " ***")
  list.out <- list(
    anova_table = anova_table,
    full_model = all_fit[[1]],
    restricted_models = all_fit[-1],
    data = prep_formulas$data) #, type = type, method = method[[1]]
  class(list.out) <- "monet"
  attr(list.out, "type") <- type
  return(list.out)
}


#' @method print monet
#' @export
print.monet <- function(x, ...) {
  tmp <- nice.monet(x, ...)
  print(tmp)
  invisible(tmp)
}

#' @method anova monet
#' @export
anova.monet <- function(object,
                        ...,
                        sig_symbols = attr(object$anova_table, "sig_symbols")) {
  anova_table <- object$anova_table
  attr(anova_table, "sig_symbols") <-
    if (!is.null(sig_symbols)) sig_symbols else
      c(" +", " *", " **", " ***")
  anova_table
}