213 add p test names

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gtsummary
 Title: Presentation-Ready Data Summary and Analytic Result
     Tables
-Version: 1.2.0
+Version: 1.2.0.9001
 Authors@R: 
     c(person(given = "Daniel D.",
              family = "Sjoberg",

NEWS.md

@@ -1,3 +1,7 @@
+# gtsummary (development version)
+
+* Added ability to name custom `add_p()` tests (#213)
+
 # gtsummary 1.2.0
 
 * Users can pass variable names in backticks (#212)

R/add_p.R

@@ -49,14 +49,16 @@
 #'   add_p()
 #'
 #' # Conduct a custom McNemar test for response,
-#' # The custom function must return a single p-value, or NA
+#' # Function must return a named list(p = ?, test = ?)
 #' add_p_test.mcnemar <- function(data, variable, by, ...) {
-#'   stats::mcnemar.test(data[[variable]], data[[by]])$p.value
+#'   result <- list()
+#'   result$p <- stats::mcnemar.test(data[[variable]], data[[by]])$p.value
+#'   result$test <- "McNemar's test"
+#'   result
 #' }
 #'
 #' add_p_ex2 <-
-#'   trial %>%
-#'   dplyr::select(response, trt) %>%
+#'   trial[c("response", "trt")] %>%
 #'   tbl_summary(by = trt) %>%
 #'   add_p(test = vars(response) ~ "mcnemar")
 #'
@@ -149,16 +151,22 @@ add_p <- function(x, test = NULL, pvalue_fun = NULL,
         group = group
       ),
       # calculating pvalue
-      p.value = calculate_pvalue(
+      test_result = calculate_pvalue(
         data = x$inputs$data,
         variable = .data$variable,
         by = x$inputs$by,
         test = .data$stat_test,
         type = .data$summary_type,
         group = group,
         include = include
-      )
-    )
+      ),
+      # grabbing p-value and test label from test_result
+      p.value = map_dbl(.data$test_result,
+                        ~pluck(.x, "p") %||% NA_real_),
+      stat_test_lbl = map_chr(.data$test_result,
+                              ~pluck(.x, "test") %||% NA_character_)
+    ) %>%
+    select(-.data$test_result)
 
   # creating pvalue column for table_body merge
   pvalue_column <-
@@ -203,28 +211,14 @@ add_p <- function(x, test = NULL, pvalue_fun = NULL,
     ")"
   )
 
-
   x
 }
 
-# creates a tibble linking test names to labels
-stat_test_names <- tibble::tribble(
-  ~stat_test, ~stat_test_label,
-  "t.test", "t-test",
-  "fisher.test", "Fisher's exact test",
-  "wilcox.test", "Wilcoxon rank-sum test",
-  "kruskal.test", "Kruskal-Wallis test",
-  "chisq.test", "chi-square test of independence",
-  "lme4", "mixed-effects regression model with random intercept"
-)
-
 # function to create text for footnote
 footnote_add_p <- function(meta_data) {
-  meta_data %>%
-    select("stat_test") %>%
-    distinct() %>%
-    left_join(stat_test_names, by = "stat_test") %>%
-    pull("stat_test_label") %>%
+  meta_data$stat_test_lbl %>%
+    keep(~!is.na(.)) %>%
+    unique() %>%
     paste(collapse = "; ") %>%
     paste0("Statistical tests performed: ", .)
 }

R/utils-add_p.R

@@ -14,24 +14,44 @@
 add_p_test <- function(data, ...) UseMethod("add_p_test")
 
 add_p_test.t.test <- function(data, variable, by, ...) {
-  stats::t.test(data[[variable]] ~ as.factor(data[[by]]))$p.value
+  result = list()
+  result$p <- stats::t.test(data[[variable]] ~ as.factor(data[[by]]))$p.value
+  result$test <- "t-test"
+  result
 }
 
 add_p_test.kruskal.test <- function(data, variable, by, ...) {
-  stats::kruskal.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result = list()
+  result$p <- stats::kruskal.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result$test <- "Kruskal-Wallis test"
+  result
 }
 
-add_p_test.wilcox.test <- add_p_test.kruskal.test
+add_p_test.wilcox.test <- function(data, variable, by, ...) {
+  result = list()
+  if (length(unique(data[[by]])) > 2)
+    stop("Wilcoxon rank-sum test cannot be calculated with more than 2 groups")
+  result$p <- stats::kruskal.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result$test <- "Wilcoxon rank-sum test"
+  result
+}
 
 add_p_test.chisq.test <- function(data, variable, by, ...) {
-  stats::chisq.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result = list()
+  result$p <- stats::chisq.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result$test <- "chi-square test of independence"
+  result
 }
 
 add_p_test.fisher.test <- function(data, variable, by, ...) {
-  stats::fisher.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result = list()
+  result$p <- stats::fisher.test(data[[variable]], as.factor(data[[by]]))$p.value
+  result$test <- "Fisher's exact test"
+  result
 }
 
 add_p_test.lme4 <- function(data, variable, by, group, type, ...) {
+  result = list()
   # input checks for lme4 tests
   if (data[[by]] %>% unique() %>% length() != 2) {
     # only allowing logistic regression models for now
@@ -57,7 +77,9 @@ add_p_test.lme4 <- function(data, variable, by, group, type, ...) {
                       data = data, family = stats::binomial)
 
   #returning p-value
-  stats::anova(mod0, mod1)$"Pr(>Chisq)"[2]
+  result$p <- stats::anova(mod0, mod1)$"Pr(>Chisq)"[2]
+  result$test <- "random intercept logistic regression"
+  result
 }
 
 
@@ -66,7 +88,7 @@ add_p_test.lme4 <- function(data, variable, by, group, type, ...) {
 add_p_test_safe <- function(data, variable, by, group, test, include = NULL, type) {
   # omitting variables not in include
   if (!variable %in% include) {
-    return(NA)
+    return(NULL)
   }
 
   # keeping non-missing values
@@ -88,19 +110,20 @@ add_p_test_safe <- function(data, variable, by, group, test, include = NULL, typ
   warning = function(w) {
     message(glue("Warning in 'add_p()' for variable '{variable}' ",
                  "and test '{test}', p-value omitted:\n", as.character(w)))
-
+    return(NULL)
   },
   error = function(e) {
     message(glue("Error in 'add_p()' for variable '{variable}' ",
                  "and test '{test}', p-value omitted:\n", as.character(e)))
+    return(NULL)
   })
 
   pval
 }
 
 # vectorized version of the functions that calculate a single pvalue
 calculate_pvalue <- function(data, variable, by, test, type, group, include) {
-  pmap_dbl(
+  pmap(
     list(variable, by, test, type),
     ~ add_p_test_safe(
       data = data, variable = ..1, by = ..2,

codemeta.json

@@ -10,7 +10,7 @@
   "codeRepository": "http://www.danieldsjoberg.com/gtsummary/",
   "issueTracker": "https://github.com/ddsjoberg/gtsummary/issues",
   "license": "https://spdx.org/licenses/MIT",
-  "version": "1.2.0",
+  "version": "1.2.0.9001",
   "programmingLanguage": {
     "@type": "ComputerLanguage",
     "name": "R",
@@ -431,7 +431,7 @@
   ],
   "releaseNotes": "https://github.com/ddsjoberg/gtsummary/blob/master/NEWS.md",
   "readme": "https://github.com/ddsjoberg/gtsummary/blob/master/README.md",
-  "fileSize": "1356.143KB",
+  "fileSize": "1356.718KB",
   "contIntegration": [
     "https://travis-ci.org/ddsjoberg/gtsummary",
     "https://ci.appveyor.com/project/ddsjoberg/gtsummary",