crsh · crsh · Jul 2, 2024 · Jan 24, 2024 · Jan 24, 2024 · Mar 15, 2024
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -46,13 +46,16 @@ Suggests:
   latex2exp,
   lme4,
   lmerTest,
+  MASS,
   MBESS,
   multcomp,
   nlme,
+  nnet,
   R.rsp,
   skimr,
   spelling,
-  testthat
+  testthat,
+  VGAM
 SystemRequirements: Rendering the document template requires
   pandoc (>= 2.0; https://pandoc.org) and for PDFs a TeX distribution,
   such as TinyTeX (>= 0.12; https://yihui.org/tinytex/)

diff --git a/R/add_custom_effect_sizes.R b/R/add_custom_effect_sizes.R
@@ -1,9 +1,10 @@
-
+#' @keywords internal
 
 add_custom_effect_sizes <- function(estimate, ...) {
   UseMethod("add_custom_effect_sizes", estimate)
 }
 
+#' @keywords internal
 
 add_custom_effect_sizes.character <- function(estimate, canonical_table, .x = NULL, ...) {
 
@@ -13,6 +14,7 @@ add_custom_effect_sizes.character <- function(estimate, canonical_table, .x = NU
   add_effect_sizes(x = canonical_table, es = estimate, ...)
 }
 
+#' @keywords internal
 
 add_custom_effect_sizes.data.frame <- function(estimate, canonical_table, intercept = FALSE, ...) {
 
@@ -32,6 +34,7 @@ add_custom_effect_sizes.data.frame <- function(estimate, canonical_table, interc
   y
 }
 
+#' @keywords internal
 
 add_custom_effect_sizes.function <- function(estimate, canonical_table, intercept = FALSE, .x = NULL, observed = NULL, ...) {
 

diff --git a/R/apa_barplot.R b/R/apa_barplot.R
@@ -67,6 +67,7 @@ apa_barplot.default <- function(
   , xlab = NULL
   , ylab = NULL
   , main = NULL
+  , set_par = TRUE
   , ...
 ){
   ellipsis <- defaults(
@@ -93,6 +94,7 @@ apa_barplot.default <- function(
       , xlab = xlab
       , ylab = ylab
       , main = main
+      , set_par = set_par
       , jit = .4  # add parameter 'space'
       , plot = c("bars", "error_bars")
     )

diff --git a/R/apa_beeplot.R b/R/apa_beeplot.R
@@ -68,6 +68,7 @@ apa_beeplot.default <- function(
   , xlab = NULL
   , ylab = NULL
   , main = NULL
+  , set_par = TRUE
   , ...
 ){
   ellipsis <- defaults(
@@ -94,6 +95,7 @@ apa_beeplot.default <- function(
       , xlab = xlab
       , ylab = ylab
       , main = main
+      , set_par = set_par
       , plot = c("points", "error_bars", "swarms")
     )
   )

diff --git a/R/apa_factorial_plot.R b/R/apa_factorial_plot.R
@@ -37,6 +37,7 @@
 #' @param ylab Character or expression. Label for *y* axis.
 #' @param main Character or expression. For up to two factors, simply specify the main title. If you stratify the data by more than two factors,
 #' either specify a single value that will be added to automatically generated main title, *or* specify an array of multiple titles, one for each plot area.
+#' @param set_par Logical. Determines whether `par(mfrow = .)` should be set for multi-panel plots.
 #' @return A named (nested) list of plot options including raw and derived data. *Note that the structure of the return value is about to change in a forthcoming release of papaja.*
 #' @inheritDotParams graphics::plot.window
 #' @details
@@ -114,6 +115,7 @@ apa_factorial_plot.default <- function(
   , xlab = NULL
   , ylab = NULL
   , main = NULL
+  , set_par = TRUE
   , ...
 ){
   # Data validation:
@@ -149,6 +151,8 @@ apa_factorial_plot.default <- function(
   if(!is.null(ylab)) if(!is.expression(ylab)) validate(ylab, check_class = "character")
   if(!is.null(main)) if(!is.expression(main)) if(!is.matrix(main)) validate(main, check_class = "character")
 
+  set_par <- isTRUE(set_par)
+
   # remove extraneous columns from dataset
   data <- data[, c(id, factors, dv)]
 
@@ -392,7 +396,7 @@ apa_factorial_plot.default <- function(
     output$args <- do.call("apa_factorial_plot_single", ellipsis)
   }
 
-  if(length(factors) > 2L) {
+  if(length(factors) > 2L && set_par) {
   oldpar <- par(no.readonly = TRUE)
   on.exit(par(oldpar))
   }
@@ -401,7 +405,7 @@ apa_factorial_plot.default <- function(
 
 
   if(length(factors) == 3) {
-    par(mfrow = c(1, nlevels(data[[factors[3]]])))
+    if(set_par) par(mfrow = c(1, nlevels(data[[factors[3]]])))
     tmp_main <- ellipsis$main
 
     # by default, only plot legend in topright plot:
@@ -457,7 +461,7 @@ apa_factorial_plot.default <- function(
 
   ## Four factors
   if(length(factors)==4){
-    par(mfrow=c(nlevels(data[[factors[3]]]),nlevels(data[[factors[4]]])))
+    if(set_par) par(mfrow=c(nlevels(data[[factors[3]]]),nlevels(data[[factors[4]]])))
     tmp_main <- ellipsis$main
 
     legend.plot <- array(FALSE, dim=c(nlevels(data[[factors[3]]]), nlevels(data[[factors[4]]])))

diff --git a/R/apa_lineplot.R b/R/apa_lineplot.R
@@ -71,6 +71,7 @@ apa_lineplot.default <- function(
   , xlab = NULL
   , ylab = NULL
   , main = NULL
+  , set_par = TRUE
   , ...
 ){
   ellipsis <- defaults(
@@ -97,6 +98,7 @@ apa_lineplot.default <- function(
       , xlab = xlab
       , ylab = ylab
       , main = main
+      , set_par = set_par
       , plot = c("points", "error_bars", "lines")
     )
   )

diff --git a/R/apa_print_BFBayesFactor.R b/R/apa_print_BFBayesFactor.R
@@ -420,11 +420,16 @@ bf_sort_terms <- function(x) {
 
 # }
 
+#' @keywords internal
 
 bf_add_estimates <- function(x, ...) UseMethod("bf_add_estimates", x@numerator[[1]])
 
+#' @keywords internal
+
 bf_add_estimates.default <- function(x, data_frame, ...) data_frame
 
+#' @keywords internal
+
 bf_add_estimates.BFoneSample   <- function(
   x
   , data_frame
@@ -462,6 +467,7 @@ bf_add_estimates.BFoneSample   <- function(
   )
 }
 
+#' @keywords internal
 
 bf_add_estimates.BFindepSample <- function(
   x
@@ -495,6 +501,8 @@ bf_add_estimates.BFindepSample <- function(
   )
 }
 
+#' @keywords internal
+
 bf_add_estimates.BFcorrelation <- function(
   x
   , data_frame
@@ -510,6 +518,8 @@ bf_add_estimates.BFcorrelation <- function(
   )
 }
 
+#' @keywords internal
+
 bf_add_estimates.BFproportion <- function(
   x
   , data_frame
@@ -528,6 +538,7 @@ bf_add_estimates.BFproportion <- function(
   )
 }
 
+#' @keywords internal
 
 bf_sample_summarize <- function(
   x
@@ -564,11 +575,16 @@ bf_sample_summarize <- function(
   data_frame
 }
 
+#' @keywords internal
 
 bf_add_names <- function(x, ...) UseMethod("bf_add_names", x@numerator[[1]])
 
+#' @keywords internal
+
 bf_add_names.default <- function(x, data_frame, ...) data_frame
 
+#' @keywords internal
+
 bf_add_names.BFlinearModel <- function(x, data_frame, ...) {
   cbind(
     model = names(x)$numerator

diff --git a/R/apa_print_anova.R b/R/apa_print_anova.R
@@ -1,9 +1,10 @@
-#' Typeset Statistical Results from ANOVA
+#' Typeset Statistical Results from Analysis of Variance (or Deviance)
 #'
-#' These methods take objects from various R functions that calculate ANOVA to
-#' create formatted character strings to report the results in accordance with
-#' APA manuscript guidelines. For `anova`-objects from model comparisons see
-#' \code{\link{apa_print.list}}.
+#' These methods take objects from various R functions that calculate analysis
+#' of variance (i.e., ANOVA) or analysis of deviance. They create formatted
+#' character strings to report the results in accordance with APA manuscript
+#' guidelines. For `anova`-objects from model comparisons see
+#' [apa_print.list()].
 #'
 #' @param x An object containing the results from an analysis of variance ANOVA
 #' @param correction Character. For repeated-measures ANOVA, the type of
@@ -415,6 +416,30 @@ apa_print.anova <- function(
         , simplify = TRUE
       )
     )
+  # stats::anova.glm() and car::Anova.glm
+  } else if(any(grepl("Deviance", object_heading))) {
+    x$Term <-rownames(x)
+    y <- canonize(x)
+    y <- remove_residuals_row(y)
+    if(all(colnames(x) != "F values")) y$df.residual <- NULL
+    if(any(colnames(x) == "Cp")) y$df <- NULL
+
+    if(is.null(y$statistic)) {
+      y$statistic <- y$deviance
+      variable_label(y$statistic) <- "$\\chi^2$"
+      y$deviance  <- NULL
+    }
+    y <- beautify(y, ...)
+    return(
+      glue_apa_results(
+        y
+        , est_glue = construct_glue(y, "estimate")
+        , stat_glue = construct_glue(y, "statistic")
+        , in_paren = in_paren
+        , simplify = TRUE
+      )
+    )
+
   } else if(any(grepl("Satterthwaite|Kenward", object_heading))) {
     # lmerTest::anova.merModLmerTest -------------------------------------------
 
@@ -481,7 +506,7 @@ apa_print.anova <- function(
   } else if(identical(object_heading[1], "ANOVA-like table for random-effects: Single term deletions")) {
     stop("Single-term deletions are not supported, yet.\nVisit https://github.com/crsh/papaja/issues to request support.")
   }
-  # anova::lm (single model) ----
+  # anova.lm() (single model) ----
   # Canonize, beautify, glue ----
   y <- as.data.frame(x, stringsAsFactors = FALSE)
   y$Effect <- trimws(rownames(y))

diff --git a/R/apa_print_htest.R b/R/apa_print_htest.R
@@ -26,7 +26,7 @@
 #'   large number of functions that produce these objects and their
 #'   idiosyncrasies, the returned strings should be compared to the original
 #'   object. If you experience inaccuracies you may report these
-#'   [here]{https://github.com/crsh/papaja/issues} (please include
+#'   [here](https://github.com/crsh/papaja/issues) (please include
 #'   a reproducible example in your report).
 #'
 #'   `stat_name` and `est_name` are placed in the output string and are thus

diff --git a/R/arrange_anova.R b/R/arrange_anova.R
@@ -35,6 +35,8 @@ arrange_anova <- function(x, ...) {
   UseMethod("arrange_anova")
 }
 
+#' @keywords internal
+
 arrange_anova.default <- function(x, ...) {
   stop(paste0("Objects of class '", class(x), "' are currently not supported (no method defined).
               Visit https://github.com/crsh/papaja/issues to request support for this class."))
@@ -43,6 +45,7 @@ arrange_anova.default <- function(x, ...) {
 
 #' @rdname arrange_anova
 #' @method arrange_anova anova
+#' @keywords internal
 
 arrange_anova.anova <- function(x, ...) {
 
@@ -83,6 +86,7 @@ arrange_anova.anova <- function(x, ...) {
 
 #' @rdname arrange_anova
 #' @method arrange_anova summary.aov
+#' @keywords internal
 
 arrange_anova.summary.aov <- function(x, ...) {
 
@@ -116,6 +120,8 @@ arrange_anova.summary.aov <- function(x, ...) {
   variance_table
 }
 
+#' @keywords internal
+
 arrange_anova.summary.aovlist <- function(x, ...) {
   x <- lapply(x, arrange_anova.summary.aov)
   variance_table <- do.call("rbind", x)
@@ -129,6 +135,7 @@ arrange_anova.summary.aovlist <- function(x, ...) {
 
 #' @rdname arrange_anova
 #' @method arrange_anova summary.Anova.mlm
+#' @keywords internal
 
 arrange_anova.summary.Anova.mlm <- function(x, correction = "GG", ...) {
   validate(correction, check_class = "character", check_length = 1)

diff --git a/R/lookup_tables.R b/R/lookup_tables.R
@@ -23,6 +23,8 @@ lookup_names <- c(
   , "BIC"     = "BIC"
   , "npar"    = "n.parameters"
   , "alternative" = "alternative"
+  , "Deviance"    = "deviance"
+  , "Resid..Dev"  = "residual.deviance" # from broom
   # term
   , "Effect"     = "term"
   , "Term"       = "term"
@@ -81,7 +83,9 @@ lookup_names <- c(
   , "F.value"   = "statistic"
   , "F"         = "statistic"
   , "F.ratio"   = "statistic"
+  , "F.values"  = "statistic"
   , "LRT"       = "statistic"
+  , "LR.Chisq"  = "statistic"
   , "Chisq"     = "statistic"
   , "chisq"     = "statistic"
   , "X.squared" = "statistic"
@@ -99,6 +103,8 @@ lookup_names <- c(
   , "logbf01"      = "statistic"
   , "Bartlett.s.K.2"          = "statistic"
   , "Bartlett.s.K.squared"    = "statistic"
+  , "Rao" = "statistic"
+  , "Cp"  = "statistic"
   # df, df.residual
   , "multivariate.df1" = "multivariate.df"
   , "multivariate.df2" = "multivariate.df.residual"
@@ -121,9 +127,11 @@ lookup_names <- c(
   , "denom.df"   = "df.residual"
   , "den.df"     = "df.residual"
   , "Res.Df"     = "df.residual"
+  , "Resid..Df"  = "df.residual"
   # p.value
   , "p.value"    = "p.value"
   , "Pr..Chisq." = "p.value"
+  , "Pr..Chi."   = "p.value"
   , "Pr..F."     = "p.value"
   , "Pr..PB."    = "p.value"
   , "Pr...t.."   = "p.value"
@@ -148,6 +156,8 @@ lookup_labels <- c(
   , "BIC"     = "$\\mathit{BIC}$"
   , "npar"    = "$k$"
   , "alternative" = "$\\mathcal{H}_1$"
+  , "Deviance"   = "$\\mathit{Dev}$"
+  , "Resid..Dev" = "$\\mathit{Dev}_{\\mathrm{res}}$"
   # term
   , "Effect"     = "Effect"
   , "Term"       = "Term"
@@ -199,8 +209,10 @@ lookup_labels <- c(
   , "F.value"   = "$F$"
   , "F"         = "$F$"
   , "F.ratio"   = "$F$"
+  , "F.values"  = "$F$"
   , "approx.F"  = "$F$"
   , "LRT"       = "$\\chi^2$"
+  , "LR.Chisq"  = "$\\chi^2$"
   , "chisq"     = "$\\chi^2$"
   , "Chisq"     = "$\\chi^2$"
   , "X.squared" = "$\\chi^2$"
@@ -218,6 +230,8 @@ lookup_labels <- c(
   , "logbf01"      = "$\\log \\mathrm{BF}_{\\textrm{01}}$"
   , "Bartlett.s.K.2"          = "$K^2$"
   , "Bartlett.s.K.squared"    = "$K^2$"
+  , "Rao" = "$\\mathit{RS}$"
+  , "Cp"  = "$C_p$"
   # df, df.residual
   , "multivariate.df" = "$\\mathit{df}$"
   , "multivariate.df.residual" = "$\\mathit{df}_{\\mathrm{res}}$"
@@ -246,6 +260,7 @@ lookup_labels <- c(
   , "Pr...z.."    = "$p$"
   , "pvalues"     = "$p$"
   , "Pr..Chisq."  = "$p$"
+  , "Pr..Chi."    = "$p$"
   , "Pr..F."      = "$p$"
   , "Pr..PB."     = "$p$"
   , "adj.p.value" = "$p_\\mathrm{adj}$"