tests/testthat/helper-structure.R

In papaja: Prepare American Psychological Association Journal Articles with R Markdown

container_names <- c("estimate", "statistic", "full_result", "table")

# Some defaults changed w/ afex 1.0.0, here we restore the behaviour of version 0.28.x
if(packageVersion("afex") >= '1.0.0') {
  afex::afex_options(
    emmeans_model = "univariate"
    , include_aov = TRUE
  )
}

# Test the general structure of apa_results ----
# 1. class apa_results/list
# 2. names container_names
# 3. anyNA?
# 4. reporting strings either character or list or NULL
# 5. table class: apa_results_table/data.frame or NULL
# 6. table columns: each column of class tiny_labelled/character
# 7. Optional: Test specific col.names
# 8. Optional: Test variable labels (and col.names)
# 9. Optional: Test names of terms in results


expect_apa_results <- function(
  object
  , col.names = NULL
  , labels = NULL
  , term_names = NULL
  , table_terms = TRUE
  , allow_row_names = FALSE
  , ...
) {

  # Recursive helper function ----
  expect_reporting_string <- function(object, ...) {
    if(is.null(object)) return(invisible(object))
    y <- rapply(list(object), f = expect_type, type = "character")
    invisible(object)
  }


  # Capture object and label ---------------------------------------------------
  act <- list(
    value = object
    , label = deparse(substitute(object))
  )

  expect_s3_class(object, c("apa_results", "list"), exact = TRUE)
  expect_identical(names(object), container_names)

  # Check for missing values ----
  expect(
    !anyNA(object, recursive = TRUE)
    , sprintf("The object `%s` contains missing values.", act$lab)
  )

  # estimate ----
  expect_reporting_string(object$estimate)

  # statistic ----
  expect_reporting_string(object$statistic)

  # full_result ----
  expect_reporting_string(object$full_result)

  # table ----
  if(!is.null(object$table)) { # allow NULL until we can add table everywhere
    table_class <- class(object$table)
    expect(
      identical(table_class, c("apa_results_table", "data.frame"))
      , sprintf(
        "The table element of `%s` has class `%s`, not `%s`."
        , act$lab, paste(table_class, collapse = "/"), "apa_results_table/data.frame"
      )
    )

    # The table element does not have row names (with the exception ofmodel comparisons)
    if(!allow_row_names) {
      expect(
        identical(rownames(object$table), as.character(seq_len(nrow(object$table))))
        , sprintf("The table element of %s has row names.", act$lab)
      )
    }


    for (i in colnames(object$table)) {
      # All columns should be of class tiny_labelled/character
      actual_class <- class(object$table[[i]])
      expect(
        identical(actual_class, c("tiny_labelled", "character"))#
        , sprintf("Column `%s` in table element of `%s` has class `%s`, not `%s`.",
                  i, act$lab, paste(actual_class, collapse = "/"), "tiny_labelled/character")
      )
    }
    if(!is.null(col.names)) {
      expect_identical(colnames(object$table), col.names)
    }
    if(!is.null(labels)) {
      expect_identical(variable_labels(object$table), labels)
    }
    if(!is.null(term_names)) {
      if(!is.null(object$estimate)) {
        expect_identical(names(object$estimate), term_names)
      }
      if(!is.null(object$statistic)) {
        expect_identical(names(object$statistic), term_names)
      }
      expect_identical(names(object$full_result), term_names)

      term_names <- term_names[term_names != "modelfit"]
      expect_identical(nrow(object$table), length(term_names))
    }
  }

  # consistency between ordering of names of reporting strings and table
  if(!is.null(object$table$term)) {
    if(isTRUE(table_terms)) {
      expect_equal(
        tolower(sanitize_terms(unlabel(gsub(object$table$term, pattern = " $\\times$ ", replacement = "_", fixed = TRUE))))
        , tolower(names(object$full_result)[!names(object$full_result) == "modelfit"])
      )
    } else {
      expect_equivalent(unclass(object$table$term)[1:nrow(object$table)], table_terms)
    }
  }

  # Invisibly return the value
  invisible(act$val)
}


expect_apa_term <- function(object, term, estimate = NULL, statistic = NULL) {
  act <- list(
    value = object
    , label = deparse(substitute(object))
  )

  full_result <- paste(c(estimate, statistic), collapse = ", ")

  expect_identical(object$estimate[[term]], estimate)
  expect_identical(object$statistic[[term]], statistic)
  expect_identical(object$full_result[[term]], full_result)

  # Invisibly return the value
  invisible(act$val)
}

# Test the test, work in progress ----
# expect_failure() somehow doesn't detect failure

# test_that(
#   "expect_apa_results"
#   , {
#     test <- papaja:::init_apa_results()
#     test$table <- data.frame(a = 1)
#
#     class(test$table) <- c("apa_results_table", "data.frame")
#     expect_failure(
#       expect_apa_results(test)
#       , "has class"
#     )
#   }
# )