Allow gt1 argument for apa_print() and printp()

R/apa_print_emm_lsm.R

@@ -125,7 +125,7 @@ apa_print.summary_emm <- function(
     contrast_table <- rename_column(contrast_table, c("t.ratio", "z.ratio"), "statistic")
     contrast_table$statistic <- printnum(contrast_table$statistic)
     contrast_table$df <- printnum(contrast_table$df, digits = dfdigits)
-    contrast_table$p.value <- printp(contrast_table$p.value)
+    contrast_table$p.value <- printp(contrast_table$p.value, ...)
   }
 
   if(ci_supplied) {

R/apa_print_glht.R

@@ -72,7 +72,7 @@ apa_print.summary.glht <- function(
   ## Format numbers
   contrast_table$estimate <- printnum(contrast_table$estimate, ...)
   contrast_table$statistic <- printnum(contrast_table$statistic, digits = 2)
-  contrast_table$p.value <- printp(contrast_table$p.value)
+  contrast_table$p.value <- printp(contrast_table$p.value, ...)
 
   # Concatenate character strings and return as named list
   apa_res <- apa_print_container()
@@ -209,7 +209,7 @@ apa_print.summary.glht <- function(
 #   if(p_supplied) {
 #     contrast_table$statistic <- printnum(contrast_table$statistic)
 #     contrast_table$df <- printnum(contrast_table$df, digits = dfdigits)
-#     contrast_table$p.value <- printp(contrast_table$p.value)
+#     contrast_table$p.value <- printp(contrast_table$p.value, ...)
 #   }
 #
 #   # Concatenate character strings and return as named list

R/apa_print_glm.R

@@ -178,8 +178,10 @@ apa_print.lm <- function(
 
   ellipsis <- list(...)
 
+  if(is.null(ellipsis$gt1)) glm_gt1 <- FALSE else glm_gt1 <- ellipsis$gt1
+
   if(is.null(est_name)) if(standardized) est_name <- "b^*" else est_name <- "b"
-  if(standardized) ellipsis$gt1 <- FALSE
+  if(standardized) ellipsis$gt1 <- glm_gt1
 
   if(is.matrix(ci)) {
     conf_level <- as.numeric(gsub("[^.|\\d]", "", colnames(ci), perl = TRUE))
@@ -206,7 +208,7 @@ apa_print.lm <- function(
   summary_x <- summary(x)
   glance_x <- broom::glance(x)
 
-  p <- printp(glance_x$p.value)
+  p <- printp(glance_x$p.value, ...)
   p <- add_equals(p)
 
   apa_res$statistic$modelfit$r2 <- paste0("$F(", summary_x$fstatistic[2], ", ", glance_x$df.residual, ") = ", printnum(glance_x$statistic), "$, $p ", p, "$") # glance_x$df
@@ -227,13 +229,13 @@ apa_print.lm <- function(
     )
 
     if(!any(is.na(c(r2_ci$Lower, r2_ci$Upper)))) { # MBESS::ci.R2 can sometimes result in NA if F is really small
-      apa_res$estimate$modelfit$r2 <- paste0("$R^2 = ", printnum(glance_x$r.squared, gt1 = FALSE, zero = FALSE), "$, ", print_confint(c(r2_ci$Lower, r2_ci$Upper), conf_level = ci_conf_level))
+      apa_res$estimate$modelfit$r2 <- paste0("$R^2 = ", printnum(glance_x$r.squared, gt1 = glm_gt1, zero = FALSE), "$, ", print_confint(c(r2_ci$Lower, r2_ci$Upper), conf_level = ci_conf_level))
     }
   } else {
-    apa_res$estimate$modelfit$r2 <- paste0("$R^2 = ", printnum(glance_x$r.squared, gt1 = FALSE, zero = FALSE), "$")
+    apa_res$estimate$modelfit$r2 <- paste0("$R^2 = ", printnum(glance_x$r.squared, gt1 = glm_gt1, zero = FALSE), "$")
   }
 
-  apa_res$estimate$modelfit$r2_adj <- paste0("$R^2_{adj} = ", printnum(glance_x$adj.r.squared, gt1 = FALSE, zero = FALSE), "$")
+  apa_res$estimate$modelfit$r2_adj <- paste0("$R^2_{adj} = ", printnum(glance_x$adj.r.squared, gt1 = glm_gt1, zero = FALSE), "$")
   apa_res$estimate$modelfit$aic <- paste0("$\\mathrm{AIC} = ", printnum(glance_x$AIC), "$")
   apa_res$estimate$modelfit$bic <- paste0("$\\mathrm{BIC} = ", printnum(glance_x$BIC), "$")
 

R/apa_print_htest.R

@@ -110,7 +110,7 @@ apa_print.htest <- function(
   }
 
   # p-value
-  p <- printp(x$p.value)
+  p <- printp(x$p.value, ...)
 
   apa_res <- apa_print_container()
   apa_res$statistic <- paste0("$", stat_name, " = ", stat, "$, $p ", add_equals(p), "$")

R/apa_print_manova.R

@@ -34,6 +34,7 @@ apa_print.manova <- function(x, test = "Pillai", ...) {
 print_manova <- function(
   x
   , in_paren = FALSE
+  , ...
 ) {
 
 
@@ -86,7 +87,7 @@ print_manova <- function(
   x[["F"]] <- printnum(x[["F"]])
   x[["df1"]] <- print_df(x[["df1"]])
   x[["df2"]] <- print_df(x[["df2"]])
-  x[["p"]] <- printp(x[["p"]])
+  x[["p"]] <- printp(x[["p"]], ...)
 
   x <- sort_terms(x, "Effect")
 

R/apa_print_merMod.R

@@ -90,7 +90,7 @@
 #'
 #'   if(isLmerTest) {
 #'     res_table$df <- print_df(res_table$df)
-#'     res_table$p.value <- printp(res_table$p.value)
+#'     res_table$p.value <- printp(res_table$p.value, ...)
 #'     res_table <- res_table[, c(est_cols, "df", "p.value")]
 #'   } else {
 #'     res_table <- res_table[, est_cols]

R/arrange_regression.R

@@ -25,7 +25,7 @@ arrange_regression <- function(x, est_name, standardized, ci, ...) {
   } else if(class(x) == "lm") {
     stat_name <- "t"
     if(is.null(est_name)) if(standardized) est_name <- "b^*" else est_name <- "b"
-    if(standardized) ellipsis$gt1 <- FALSE
+    if(standardized & is.null(ellipsis$gt1)) ellipsis$gt1 <- FALSE
   }
 
   if(is.matrix(ci)) {
@@ -51,7 +51,7 @@ arrange_regression <- function(x, est_name, standardized, ci, ...) {
 
   regression_table$estimate <- do.call(function(...) printnum(regression_table$estimate, ...), ellipsis)
   regression_table$statistic <- printnum(regression_table$statistic, digits = 2)
-  regression_table$p.value <- printp(regression_table$p.value)
+  regression_table$p.value <- printp(regression_table$p.value, ...)
 
   colnames(regression_table) <- c("predictor", "estimate", "ci", "statistic", "p.value")
 

R/print_anova.R

@@ -41,6 +41,7 @@ print_anova <- function(
   , es = "ges"
   , mse = getOption("papaja.mse")
   , in_paren = FALSE
+  , ...
 ) {
 
   # When processing aovlist objects, the `(Intercept)` is kept to preserve the
@@ -50,6 +51,9 @@ print_anova <- function(
   validate(x, check_class = "apa_variance_table", check_NA = FALSE)
   validate(intercept, check_class = "logical", check_length = 1)
 
+  ellipsis <- list(...)
+  if(is.null(ellipsis$gt1)) apa_gt1 <- FALSE else apa_gt1 <- ellipsis$gt1
+
   if(!is.null(observed)) validate(observed, check_class = "character")
   if(!is.null(es)) {
     validate(es, check_class = "character")
@@ -73,10 +77,10 @@ print_anova <- function(
 
   # Rounding and filling with zeros
   x$statistic <- printnum(x$statistic, digits = 2)
-  x$p.value <- printp(x$p.value)
+  x$p.value <- printp(x$p.value, ...)
   x$df <- print_df(x$df)
   x$df_res <- print_df(x$df_res)
-  for(i in es) {x[[i]] <- printnum(x[[i]], digits = 3, gt1 = FALSE)}
+  for(i in es) {x[[i]] <- printnum(x[[i]], digits = 3, gt1 = apa_gt1)}
   if(mse) x$mse <- printnum(x$mse, digits = 2)
 
   # Assemble table -------------------------------------------------------------

R/print_model_comp.R

@@ -41,6 +41,7 @@ print_model_comp <- function(
   , boot_samples = 1000
   , in_paren = FALSE
   , observed_predictors = TRUE
+  , ...
 ) {
   validate(x, check_class = "data.frame")
   validate(x, check_class = "apa_model_comp")
@@ -52,7 +53,10 @@ print_model_comp <- function(
     rownames(x) <- names(models)[-1]
   } else rownames(x) <- sanitize_terms(x$term)
 
-  # Concatenate character strings and return as named list
+  ellipsis <- list(...)
+  if(is.null(ellipsis$gt1)) apa_gt1 <- FALSE else apa_gt1 <- ellipsis$gt1
+
+    # Concatenate character strings and return as named list
   apa_res <- apa_print_container()
 
   ## est
@@ -64,7 +68,7 @@ print_model_comp <- function(
     apa_res$estimate <- sapply(
       seq_along(delta_r2s)
       , function(y) {
-        delta_r2_res <- printnum(delta_r2s[y], gt1 = FALSE, zero = FALSE)
+        delta_r2_res <- printnum(delta_r2s[y], gt1 = apa_gt1, zero = FALSE)
         paste0("$\\Delta R^2 ", add_equals(delta_r2_res), "$")
       }
     )
@@ -74,11 +78,11 @@ print_model_comp <- function(
     model_summaries <- lapply(models, summary)
     r2s <- sapply(model_summaries, function(x) x$r.squared)
     delta_r2s <- diff(r2s)
-    delta_r2_res <- printnum(delta_r2s, gt1 = FALSE, zero = FALSE)
+    delta_r2_res <- printnum(delta_r2s, gt1 = apa_gt1, zero = FALSE)
 
     apa_res$estimate <- paste0(
       "$\\Delta R^2 ", add_equals(delta_r2_res), "$, ", ci * 100, "\\% CI "
-      , apply(boot_r2_ci, 1, print_confint, gt1 = FALSE)
+      , apply(boot_r2_ci, 1, print_confint, gt1 = apa_gt1)
     )
   }
 
@@ -87,7 +91,7 @@ print_model_comp <- function(
   x$statistic <- printnum(x$statistic)
   x$df <- print_df(x$df)
   x$df_res <- print_df(x$df_res)
-  x$p.value <- printp(x$p.value, add_equals = TRUE)
+  x$p.value <- printp(x$p.value, add_equals = TRUE, ...)
 
   apa_res$statistic <- paste0("$F(", x[["df"]], ", ", x[["df_res"]], ") = ", x[["statistic"]], "$, $p ", x[["p.value"]], "$")
   if(in_paren) apa_res$statistic <- in_paren(apa_res$statistic)
@@ -133,10 +137,12 @@ print_model_comp <- function(
   }
   model_diffs <- as.data.frame(model_diffs, stringsAsFactors = FALSE)
 
+  if(is.null(ellipsis$gt1) | !ellipsis$gt1) fits_gt1 <- c(FALSE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE) else fits_gt1 <- TRUE
+
   model_fits <- printnum(
     model_fits
     , margin = 2
-    , gt1 = c(FALSE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE)
+    , gt1 = fits_gt1
     , zero = c(FALSE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE)
     , digits = c(2, 2, 0, 0, 3, 2, 2)
   )
@@ -151,10 +157,11 @@ print_model_comp <- function(
   colnames(model_fits) <- c(paste0("$R^2$ [", ci * 100, "\\% CI]"), "$F$", "$df_1$", "$df_2$", "$p$", "$\\mathrm{AIC}$", "$\\mathrm{BIC}$")
 
   ## Add differences in model fits
+  if(is.null(ellipsis$gt1) | !ellipsis$gt1) diffs_gt1 <- c(FALSE, TRUE, TRUE) else diffs_gt1 <- TRUE
   model_diffs <- printnum(
     model_diffs
     , margin = 2
-    , gt1 = c(FALSE, TRUE, TRUE)
+    , gt1 = diffs_gt1
     , zero = c(FALSE, TRUE, TRUE)
   )
   model_diffs[, "r.squared"] <- gsub(", \\d\\d\\\\\\% CI", "", gsub("\\\\Delta R\\^2 = ", "", unlist(apa_res$estimate))) # Replace by previous estimate with CI

R/printnum.R

@@ -375,12 +375,12 @@ printnumber <- function(x, gt1 = TRUE, zero = TRUE, na_string = "", use_math = T
 #' printp(0.99999999)
 #' @export
 
-printp <- function(x, digits = 3L, na_string = "", add_equals = FALSE) {
+printp <- function(x, digits = 3L, na_string = "", add_equals = FALSE, gt1 = FALSE) {
   validate(x, check_class = "numeric", check_range = c(0, 1), check_NA = FALSE)
   validate(na_string, check_class = "character", check_length = 1)
   validate(digits, check_class = "numeric")
 
-  p <- printnum(x, digits = digits, gt1 = FALSE, zero = FALSE, na_string = na_string, add_equals = add_equals)
+  p <- printnum(x, digits = digits, gt1 = gt1, zero = FALSE, na_string = na_string, add_equals = add_equals)
   p
 }