Merge pull request #498 from crsh/deprecate-ci

deprecate 'ci', 'conf.level', and 'args_confint' in an orderly manner

R/apa_print_emm_lsm.R

@@ -11,7 +11,7 @@
 #' \pkg{emmeans}.
 #' @param contrast_names Character. An optional vector of names to label the
 #' calculated contrasts.
-#' @param conf.level Numeric. Confidence level for confidence intervals.
+#' @param conf.int Numeric. Confidence level for confidence intervals.
 #' @inheritParams emmeans::summary.emmGrid
 #' @inheritParams glue_apa_results
 #' @inheritDotParams printnum
@@ -39,13 +39,17 @@
 #' @method apa_print emmGrid
 #' @export
 
-apa_print.emmGrid <- function(x, infer = TRUE, conf.level = 0.95, ...) {
- ellipsis <- list(...)
+apa_print.emmGrid <- function(x, infer = TRUE, conf.int = 0.95, ...) {
+
+ ellipsis_ci <- deprecate_ci(conf.int = conf.int, ...)
+ conf.int <- ellipsis_ci$conf.int
+ ellipsis <- ellipsis_ci$ellipsis
+
  if(is.null(ellipsis$est_name)) {
  ellipsis$est_name <- est_name_from_call(x)
  }
 
- ellipsis$x <- summary(x, infer = infer, level = conf.level)
+ ellipsis$x <- summary(x, infer = infer, level = conf.int)
 
  # Add family size, because it gets lost otherwise
  famSize <- attr(x, "misc")$famSize

R/apa_print_glht.R

@@ -36,7 +36,9 @@ apa_print.summary.glht <- function(
  , in_paren = FALSE
  , ...
 ) {
- deprecate_ci(...)
+ ellipsis_ci <- deprecate_ci(conf.int, ...)
+ ellipsis <- ellipsis_ci$ellipsis
+ conf.int <- ellipsis_ci$conf.int
 
  validate(x, check_class = "summary.glht")
  validate(conf.int, check_class = "numeric", check_length = 1, check_range = c(0, 1))
@@ -47,19 +49,19 @@ apa_print.summary.glht <- function(
  conf_level <- paste0(conf.int * 100, "% CI")
  p_value <- names(tidy_x)[grepl("p.value", names(tidy_x), fixed = TRUE)]
 
- # Assamble table
- ## Add (adjusted) confidence intervall
+ # Assemble table
+ ## Add (adjusted) confidence interval
  multcomp_adjustment <- if(x$test$type == "none") multcomp::univariate_calpha() else multcomp::adjusted_calpha()
  print_ci <- stats::confint(x, level = conf.int, calpha = multcomp_adjustment)$confint
  dimnames(print_ci) <- NULL
- table_ci <- unlist(print_confint(print_ci[, -1], ...)) # Remove point estimate from matrix
+ table_ci <- unlist(do.call("print_confint", c(list(x = print_ci[, -1]), ellipsis))) # Remove point estimate from matrix
  tidy_x$std.error <- table_ci
  colnames(tidy_x)[colnames(tidy_x) == "std.error"] <- "conf.int"
 
  ## Typeset columns
  sanitzied_contrasts <- sanitize_terms(tidy_x$contrast)
  tidy_x$contrast <- beautify_terms(tidy_x$contrast)
- tidy_x$estimate <- printnum(tidy_x$estimate, ...)
+ tidy_x$estimate <- do.call("printnum", c(list(x = tidy_x$estimate), ellipsis))
  tidy_x$statistic <- printnum(tidy_x$statistic, digits = 2)
  tidy_x[[p_value]] <- printp(tidy_x[[p_value]])
 

R/apa_print_glm.R

@@ -96,7 +96,9 @@ apa_print.glm <- function(
  , in_paren = FALSE
  , ...
 ) {
- deprecate_ci(...)
+ ellipsis_ci <- deprecate_ci(conf.int, ...)
+ ellipsis <- ellipsis_ci$ellipsis
+ conf.int <- ellipsis_ci$conf.int
 
  validate(x, check_class = "glm")
 
@@ -161,7 +163,9 @@ apa_print.lm <- function(
  , ...
 ) {
 
- deprecate_ci(...)
+ ellipsis_ci <- deprecate_ci(conf.int = conf.int, ...)
+ ellipsis <- ellipsis_ci$ellipsis
+ conf.int <- ellipsis_ci$conf.int
 
  validate(x, check_class = "lm")
  if(!is.null(est_name)) validate(est_name, check_class = "character", check_length = 1)
@@ -177,7 +181,6 @@ apa_print.lm <- function(
  } else validate(conf.int)
  validate(in_paren, check_class = "logical", check_length = 1)
 
- ellipsis <- list(...)
 
  if(is.null(est_name)) if(standardized) est_name <- "b^*" else est_name <- "b"
  if(standardized) ellipsis$gt1 <- FALSE
@@ -189,12 +192,17 @@ apa_print.lm <- function(
  conf_level <- 100 * conf.int
  }
 
- regression_table <- arrange_regression(
- x
- , est_name = est_name
- , standardized = standardized
- , conf.int = conf.int
- , ...
+ regression_table <- do.call(
+ "arrange_regression"
+ , c(
+ list(
+ x = x
+ , est_name = est_name
+ , standardized = standardized
+ , conf.int = conf.int
+ )
+ , ellipsis
+ )
  )
 
  # Concatenate character strings and return as named list

R/apa_print_htest.R

@@ -71,7 +71,9 @@ apa_print.htest <- function(
  , in_paren = FALSE
  , ...
 ) {
- deprecate_ci(...)
+ ellipsis_ci <- deprecate_ci(conf.int, ...)
+ ellipsis <- ellipsis_ci$ellipsis
+ conf.int <- ellipsis_ci$conf.int
 
  validate(x, check_class = "htest")
  if(!is.null(stat_name)) validate(stat_name, check_class = "character", check_length = 1)
@@ -80,7 +82,7 @@ apa_print.htest <- function(
  if(!is.null(conf.int)) validate(conf.int, check_class = "numeric", check_length = 2)
  validate(in_paren, check_class = "logical", check_length = 1)
 
- ellipsis <- list(...)
+
 
  # Arrange table, i.e. coerce 'htest' to a proper data frame ----
 

R/apa_print_list.R

@@ -93,7 +93,9 @@ apa_print.list <- function(
  , ...
 ) {
 
- deprecate_ci(...)
+ ellipsis_ci <- deprecate_ci(conf.int, ...)
+ ellipsis <- ellipsis_ci$ellipsis
+ conf.int <- ellipsis_ci$conf.int
 
  if(length(x) == 1) apa_print(x[[1]]) else {
  if(class(x[[1]]) != "lm") stop("Currently, only model comparisons for 'lm' objects are supported.")
@@ -108,7 +110,7 @@ apa_print.list <- function(
 
  # Compare models
  names(x) <- NULL
- model_comp <- do.call(anova_fun, x, ...)
+ model_comp <- do.call(anova_fun, c(x, ellipsis))
 
  variance_table <- arrange_anova(model_comp)
  if(!is.null(model_labels) & sum(model_labels != "") == length(model_labels)) {

R/apa_print_merMod.R

@@ -45,13 +45,9 @@ apa_print.merMod <- function(
 ) {
 
  # Input validation and processing ----
- ellipsis <- list(...)
-
- if(!is.null(ellipsis$args)) {
- warning("Argument 'args_confint' has been deprecated. Please use 'conf.int' instead.")
- conf.int <- ellipsis$args
- ellipsis$args_confint <- NULL
- }
+ ellipsis_ci <- deprecate_ci(conf.int, ...)
+ ellipsis <- ellipsis_ci$ellipsis
+ conf.int <- ellipsis_ci$conf.int
 
  if(is.list(conf.int)) {
  validate(conf.int, check_class = "list")

R/deprecated_defunct.R

@@ -117,13 +117,42 @@ apa_table.word <- function(x, ...) {
 }
 
 
-deprecate_ci <- function(...) {
- if(any(names(list(...)) == "ci")) {
- stop("Using argument 'ci' in calls to 'apa_print()' is now defunct. Please use 'conf.int' instead.", call. = FALSE)
+deprecate_ci <- function(conf.int, ...) {
+ x <- list(...)
+
+ partial_matches <- pmatch(names(x), table = c("ci", "conf.level", "args_confint"), duplicates.ok = TRUE)
+ names(partial_matches) <- c("ci", "conf.level", "args_confint")[partial_matches]
+ x_deprecated <- x[!is.na(partial_matches)]
+ names(x_deprecated) <- names(partial_matches[!is.na(partial_matches)])
+ if(length(x_deprecated) > 1L) {
+ stop(
+ "Using arguments "
+ , paste(encodeString(names(x_deprecated), quote = "'"), collapse = " and ")
+ , " in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead. "
+ , "Your call to 'apa_print()' failed because conflicting deprecated arguments were provided."
+ , call. = FALSE
+ )
+ }
+
+ if(length(x_deprecated)) {
+ warning(
+ "Using argument "
+ , encodeString(names(x_deprecated), quote = "'")
+ , " in calls to 'apa_print()' is deprecated. "
+ , "Please use 'conf.int' instead."
+ , call. = FALSE
+ )
+ conf.int <- x_deprecated[[1L]]
  }
+ list(
+ conf.int = conf.int
+ , ellipsis = x[is.na(partial_matches)]
+ )
 }
 
 
+
+
 prettify_terms <- function(...) {
  .Defunct("beautify_terms")
  beautify_terms(...)

tests/testthat/test_apa_print_emm_lsm.R

@@ -17,7 +17,11 @@ test_that(
  # Main effect ------------------------------------------------------
 
  tw_me_emm <- emmeans::emmeans(tw_rm, ~ Valence)
- tw_me_emm_output <- apa_print(tw_me_emm)
+ tw_me_emm_output <- expect_warning(
+ apa_print(tw_me_emm, conf.l = .95)
+ , regexp = "Using argument 'conf.level' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
+ , fixed = TRUE
+ )
 
  expect_apa_results(
  tw_me_emm_output
@@ -474,7 +478,7 @@ test_that(
  # Ensure proper sorting of terms
  load("data/mixed_data.rdata")
  unsorted_aov <- afex::aov_4(formula = Recall ~ Gender * Dosage * (Task * Valence |Subject), data = mixed_data, fun_aggregate = mean)
- 
+
  unsorted_emm <- emmeans::joint_tests(unsorted_aov, by = "Gender")
  apa_out <- apa_print(unsorted_emm)
 
@@ -488,7 +492,7 @@ test_that(
  , df.residual = "$\\mathit{df}_{\\mathrm{res}}$"
  , p.value = "$p$"
  )
- , term_names = papaja:::sanitize_terms(paste(unlabel(gsub(apa_out$table$term, pattern = " $\\times$ ", replacement = "_", fixed = TRUE)), apa_out$table$Gender, sep = "_")) 
+ , term_names = papaja:::sanitize_terms(paste(unlabel(gsub(apa_out$table$term, pattern = " $\\times$ ", replacement = "_", fixed = TRUE)), apa_out$table$Gender, sep = "_"))
  , table_terms = beautify_terms(data.frame(unsorted_emm)$model.term)
  )
  }

tests/testthat/test_apa_print_glht.R

@@ -52,3 +52,17 @@ test_that(
  )
  }
 )
+
+test_that(
+ "Deprecated 'ci' argument"
+ , {
+ amod <- aov(breaks ~ tension, data = warpbreaks)
+ comparisons <- multcomp::glht(amod, linfct = multcomp::mcp(tension = "Tukey"))
+
+ expect_warning(
+ apa_print(comparisons, ci = .99)
+ , regexp = "Using argument 'ci' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
+ , fixed = TRUE
+ )
+ }
+)

tests/testthat/test_apa_print_glm.R

@@ -112,10 +112,10 @@ test_that(
  # No CI information
  expect_error(apa_print(lm_fit, conf.int = NULL), "The parameter 'conf.int' is NULL.")
 
- # defunct argument 'ci'
- expect_error(
+ # deprecated argument 'ci'
+ expect_warning(
  apa_print(lm_fit, ci = .95)
- , "Using argument 'ci' in calls to 'apa_print()' is now defunct. Please use 'conf.int' instead."
+ , "Using argument 'ci' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
  , fixed = TRUE
  )
 

tests/testthat/test_apa_print_htest.R

@@ -422,3 +422,14 @@ test_that(
  expect_error(apa_print(degenerate, stat_name = "t"), "No statistic available in results table.")
  }
 )
+
+test_that(
+ "Deprecated 'ci' argument"
+ , {
+ expect_warning(
+ apa_print(t.test(yield ~ N, npk), ci = c(1, 2))
+ , regexp = "Using argument 'ci' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
+ , fixed = TRUE
+ )
+ }
+)

tests/testthat/test_apa_print_merMod.R

@@ -127,7 +127,8 @@ test_that(
 
  expect_warning(
  apa_print(gm1, args_confint = list(level = .90))
- , "Argument 'args_confint' has been deprecated. Please use 'conf.int' instead."
+ , "Using argument 'args_confint' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
+ , fixed = TRUE
  )
 
  expect_apa_results(
@@ -317,7 +318,7 @@ test_that(
  ungroup() %>%
  mutate(errors=floor(runif(n=40,min=0,max=30)))
 
- glmm <- afex::mixed(errors~group*session*task+(1|participant), df)
+ glmm <- afex::mixed(errors~group*session*task+(1|participant), df, progress = interactive())
  apa_t <- apa_print(glmm$full_model)
 
  expect_apa_results(
@@ -332,7 +333,7 @@ test_that(
  )
  )
 
- glmm <- afex::mixed(errors~group*session*task+(1|participant), df, family = "poisson", method = "LRT")
+ glmm <- afex::mixed(errors~group*session*task+(1|participant), df, family = "poisson", method = "LRT", progress = interactive())
  apa_LRT <- apa_print(glmm)
 
  expect_apa_results(
@@ -346,3 +347,17 @@ test_that(
  )
  }
 )
+
+test_that(
+ "Deprecated 'args_confint' argument"
+ , {
+ data(sleepstudy, package = "lme4")
+ fm1 <- lme4::lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
+
+ expect_warning(
+ apa_print(fm1, args_confint = list(level = .99, method = "profile"))
+ , regexp = "Using argument 'args_confint' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
+ , fixed = TRUE
+ )
+ }
+)

tests/testthat/test_apa_print_model_comp.R

@@ -117,6 +117,24 @@ test_that(
  }
 )
 
+test_that(
+ "Deprecated 'ci' argument"
+ , {
+ mod1 <- lm(yield ~ N, npk)
+ mod2 <- lm(yield ~ N * P, npk)
+
+ expect_warning(
+ apa_out <- apa_print(list(mod1, mod2), boot_samples = 0L, ci = .96)
+ , regexp = "Using argument 'ci' in calls to 'apa_print()' is deprecated. Please use 'conf.int' instead."
+ , fixed = TRUE
+ )
+ expect_identical(
+ as.character(apa_out$table$`Model 1`[[1L]], keep_label = FALSE)
+ , "52.07 [48.02, 56.11]"
+ )
+ }
+)
+
 # context("apa_print.anova() - Model comparison")
 #
 # test_that(