Merge pull request #584 from crsh/issue583

apa_print() methods for **emmeans**: Improves term names and removes row names of table element

DESCRIPTION

@@ -58,7 +58,7 @@ SystemRequirements: Rendering the document template requires
   such as TinyTeX (>= 0.12; https://yihui.org/tinytex/)
 License: MIT + file LICENSE
 Encoding: UTF-8
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 VignetteBuilder: knitr, R.rsp
 Language: en-US
 Roxygen: list(markdown = TRUE)

R/apa_print_emm_lsm.R

@@ -167,7 +167,7 @@ apa_print.summary_emm <- function(
     stat_colnames <- c("statistic", df_colname, p_value)
   }
 
-  # Assamble table
+  # Assemble table
 
   ## Add split variables
   split_by <- attr(x, "by.vars") # lsmeans
@@ -257,28 +257,20 @@ apa_print.summary_emm <- function(
   ## Add contrast names
   # rownames(tidy_x) <- if(!is.null(contrast_names)) contrast_names else tidy_x$contrast
   # tidy_x <- tidy_x[, which(colnames(tidy_x) != "contrast")]
+
   if(length(factors) > 1) {
     contrast_row_names <- apply(
       tidy_x[, c(factors[which(factors != "contrast")], factors[which(factors == "contrast")])]
-      , 1
-      , paste
+      , MARGIN = 1L
+      , FUN = paste
       , collapse = "_"
     )
   } else if(length(factors) == 1) {
-    contrast_row_names <- tidy_x[, factors]
+    contrast_row_names <- tidy_x[, factors, drop = TRUE]
   } else {
     stop("Could not determine names to address each result by.")
   }
-
-  rownames(tidy_x) <- sanitize_terms(
-    gsub( # Leading or double underscores from simple contrasts where there are dots in some columns that are replaced by ""
-      "^\\_|\\_(\\_)", "\\1"
-      , gsub(
-        " |\\.", ""
-        , gsub("\\.0+$", "", contrast_row_names) # Removes trailing zero-digits for numeric predictors
-      )
-    )
-  )
+  terms_sanitized <- sanitize_terms(contrast_row_names)
 
   ## Mark test families (see below)
   if(!is.null(attr(x, "famSize"))) {
@@ -336,7 +328,7 @@ apa_print.summary_emm <- function(
     , est_glue = est_glue(tidy_x)
     , stat_glue = stat_glue(tidy_x)
     , in_paren = in_paren
-    , term_names = make.names(rownames(tidy_x))
+    , term_names = make.names(terms_sanitized)
   )
 
   ## Mark test families

R/utils_text.R

@@ -53,8 +53,10 @@ sanitize_terms.character <- function(x, standardized = FALSE) {
   x <- gsub("\\(|\\)|`", "", x)                     # Remove parentheses and backticks
   x <- gsub("\\.0+$", "", x)                        # Remove trailing 0-digits
   x <- gsub(",", "", x)                             # Remove big mark
-  x <- gsub(" \\+ ", "_", x)                        # Remove '+' in model names
-  x <- gsub("\\W", "_", x)                          # Replace non-word characters with "_"
+  x <- gsub(" \\+ ", "_", x)                        # Replace '+' in model names
+  x <- gsub("\\W", "_", x)                          # Replace non-alphanumeric characters with "_"
+  x <- gsub("_+", "_", x)                           # Replace multiple consecutive underscores with "_"
+  x <- gsub("^_", "", x)                            # Remove leading underscores
   x
 }
 

inst/NEWS.md

@@ -7,6 +7,10 @@
 - `generate_author_yml()`
     - Now preserves affiliation order for each author (see #569).
 - `apa_print()` now supports output from `stats::binom.test()` (see [#576](https://github.com/crsh/papaja/issues/576)).
+- `sanitize_terms()` now also replaces multiple consecutive underscores with a single underscore and removes leading underscores. This affects term names in output from `apa_print()`.
+- `apa_print()` now returns an output object that is consistent with other output from `apa_print()`
+  - The table element does not have row names.
+  - Term names are now consistently constructed with `sanitize_terms()`.
 
 # papaja 0.1.2
 

tests/testthat/helper-structure.R

@@ -26,6 +26,7 @@ expect_apa_results <- function(
   , labels = NULL
   , term_names = NULL
   , table_terms = TRUE
+  , allow_row_names = FALSE
   , ...
 ) {
 
@@ -72,6 +73,14 @@ expect_apa_results <- function(
       )
     )
 
+    # 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

tests/testthat/test_apa_print_model_comp.R

@@ -11,7 +11,7 @@ test_that(
     # No bootstrapped Delta R^2 CI
     model_comp <- apa_print(list(Baseline = mod1, Length = mod2, Both = mod3), boot_samples = 0)
 
-    expect_apa_results(model_comp)
+    expect_apa_results(model_comp, allow_row_names = TRUE)
 
     # stat
     expect_identical(names(model_comp$stat), c("Length", "Both"))
@@ -60,7 +60,7 @@ test_that(
 
     # Test omission of incomplete model names & CI
     incomplete_names <- apa_print(list(mod1, Length = mod2, Both = mod3), boot_samples = 0)
-    expect_apa_results(incomplete_names)
+    expect_apa_results(incomplete_names, allow_row_names = TRUE)
 
     ## stat
     expect_identical(names(incomplete_names$stat), c("model2", "model3"))
@@ -75,7 +75,7 @@ test_that(
     expect_identical(colnames(incomplete_names$table), paste("Model", 1:3))
 
     incomplete_names2 <- apa_print(list(mod1, mod2, mod3), boot_samples = 0)
-    expect_apa_results(incomplete_names2)
+    expect_apa_results(incomplete_names2, allow_row_names = TRUE)
     expect_identical(incomplete_names, incomplete_names2)
 
 
@@ -84,14 +84,14 @@ test_that(
 
     set.seed(1337)
     model_comp_boot <- apa_print(list(Baseline = mod1, Length = mod2, Both = mod3), boot_samples = 1e3)
-    expect_apa_results(model_comp_boot)
+    expect_apa_results(model_comp_boot, allow_row_names = TRUE)
 
     expect_identical(model_comp_boot$est$Length, "$\\Delta R^2 = .83$, 90\\% CI $[.76, .86]$")
 
     expect_identical(model_comp_boot$est$Both, "$\\Delta R^2 = .02$, 90\\% CI $[.01, .04]$")
 
     model_comp_boot2 <- apa_print(list(Baseline = mod1, Length = mod2), boot_samples = 1e3, conf.int = 0.5)
-    expect_apa_results(model_comp_boot2)
+    expect_apa_results(model_comp_boot2, allow_row_names = TRUE)
 
     expect_identical(model_comp_boot2$est$Length, "$\\Delta R^2 = .83$, 50\\% CI $[.80, .84]$")
 
@@ -152,6 +152,7 @@ test_that(
 
     expect_apa_results(
       apa_out
+      , allow_row_names = TRUE
     )
   }
 )