-

matcasti · Aug 6, 2021 · 9d673c4 · 9d673c4
1 parent 6837f55
commit 9d673c4
Show file tree

Hide file tree

Showing 17 changed files with 423 additions and 300 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as.data.frame,writR)
+S3method(print,writR)
 export(aov_r)
 export(autest)
 export(cent_disp)
@@ -12,6 +14,7 @@ export(lablr)
 export(one_sample)
 export(pairs_two_sample)
 export(pairwise_test)
+export(sphericity_check)
 export(style.p)
 export(two_sample)
 importFrom(PMCMRplus,durbinAllPairsTest)

diff --git a/R/aov_r.R b/R/aov_r.R
@@ -38,10 +38,10 @@ aov_r <- function(data,
 
   is.empty <- function(i) length(i) == 0
 
-  data <- droplevels(data[j = .SD, .SDcols = c(rowid, response, between, within)])
   is.null(response) && stop("'response' can't be null", call. = FALSE)
   is.empty(between) && is.empty(within) && stop("Need to specify one of between or within factors", call. = FALSE)
   is.null(rowid) && stop("'rowid' can't be null", call. = FALSE)
+  data <- droplevels(data[j = .SD, .SDcols = c(rowid, response, between, within)])
 
   model <- suppressMessages(
     suppressWarnings(
@@ -99,7 +99,7 @@ aov_r <- function(data,
     method = data.table::fcase(rn %chin% between, "Fisher's ANOVA",
                    rn %chin% within, within_method,
                    utils::combn(within, 1, grepl, T, rn), within_method),
-    alternative = NA,
+    alternative = NA_character_,
     estimate = efs[[2L]],
     conf.level = efs$CI,
     conf.low = efs$CI_low,

diff --git a/R/contingency.R b/R/contingency.R
@@ -42,7 +42,7 @@ contingency <- function(data
     .f <- stats::fisher.test(tab)
     .es <- try(expr = effectsize::oddsratio(tab, ci = conf.level), silent = TRUE)
     if("try-error" %chin% class(.es)) {
-      .es <- rep(NA, 4)
+      .es <- rep(NA_real_, 4)
       .es <- `names<-`(.es, rep(NA, 4))
       .f$method <- paste(.f$method, "without OR")
     }
@@ -53,14 +53,14 @@ contingency <- function(data
   }
 
   res <- list(
-    y = if (is.null(y)) as.character(NA) else y,
+    y = if (is.null(y)) NA_character_ else y,
     x = x,
-    statistic = if (is.null(.f$statistic)) as.numeric(NA) else .f$statistic,
-    df = if (is.null(.f$parameter)) as.numeric(NA) else .f$parameter,
-    df.error = as.numeric(NA),
+    statistic = if (is.null(.f$statistic)) NA_real_ else .f$statistic,
+    df = if (is.null(.f$parameter)) NA_real_ else .f$parameter,
+    df.error = NA_real_,
     p.value = .f$p.value,
     method = .f$method,
-    alternative = as.character(NA),
+    alternative = NA_character_,
     estimate = as.numeric(.es[[1L]]),
     conf.level = as.numeric(.es[[2L]]),
     conf.low = as.numeric(.es[[3L]]),
@@ -70,9 +70,11 @@ contingency <- function(data
   )
 
   if(lbl) {
-    res <- lablr(res, markdown = markdown)
+    res <- lablr(res, markdown)
   }
 
+  class(res) <- c("writR", "list")
+
   return(res)
 }
 
diff --git a/R/k_sample.R b/R/k_sample.R
@@ -121,7 +121,7 @@ k_sample <- function(data, x, y,
         } else {
           paste("Repeated measures ANOVA with", sphericity, "correction")
         },
-        alternative = as.character(NA),
+        alternative = NA_character_,
         estimate = es[[2L]],
         conf.level = es[["CI"]],
         conf.low = es[["CI_low"]],
@@ -130,7 +130,13 @@ k_sample <- function(data, x, y,
         n_obs = length(y_var) / length(x_lvl)
       )
 
-      if(lbl) return(lablr(test, markdown)) else return(test)
+      if(lbl) {
+        test <- lablr(test, markdown)
+      }
+
+      class(test) <- c("writR", "list")
+
+      return(test)
     } else {
 
       test <- stats::oneway.test(
@@ -148,7 +154,7 @@ k_sample <- function(data, x, y,
         df.error = test$parameter[["denom df"]],
         p.value = test$p.value,
         method = if (var.equal) "Fisher's ANOVA" else "Welch's ANOVA",
-        alternative = as.character(NA),
+        alternative = NA_character_,
         estimate = es[[1L]],
         conf.level = es[["CI"]],
         conf.low = es[["CI_low"]],
@@ -157,7 +163,13 @@ k_sample <- function(data, x, y,
         n_obs = length(y_var)
       )
 
-      if(lbl) return(lablr(test, markdown)) else return(test)
+      if(lbl) {
+        test <- lablr(test, markdown)
+      }
+
+      class(test) <- c("writR", "list")
+
+      return(test)
     }
   }
   # Non-parametric statistics
@@ -183,10 +195,10 @@ k_sample <- function(data, x, y,
         "x" = x,
         statistic = test$statistic,
         df = as.double(test$parameter),
-        df.error = as.double(NA),
+        df.error = NA_real_,
         p.value = test$p.value,
         method = test$method,
-        alternative = as.character(NA),
+        alternative = NA_character_,
         estimate = es[[1L]],
         conf.level = es[["CI"]],
         conf.low = es[["CI_low"]],
@@ -195,7 +207,13 @@ k_sample <- function(data, x, y,
         n_obs = length(y_var) / length(x_lvl)
       )
 
-      if(lbl) return(lablr(test, markdown)) else return(test)
+      if(lbl) {
+        test <- lablr(test, markdown)
+      }
+
+      class(test) <- c("writR", "list")
+
+      return(test)
     # Kruskal-Wallis rank-sum test for independent samples
     } else {
       test <- stats::kruskal.test(
@@ -214,10 +232,10 @@ k_sample <- function(data, x, y,
         "x" = x,
         statistic = test$statistic,
         df = as.double(test$parameter),
-        df.error = as.double(NA),
+        df.error = NA_real_,
         p.value = test$p.value,
         method = test$method,
-        alternative = as.character(NA),
+        alternative = NA_character_,
         estimate = es[[1L]],
         conf.level = es[["CI"]],
         conf.low = es[["CI_low"]],
@@ -226,7 +244,13 @@ k_sample <- function(data, x, y,
         n_obs = length(y_var)
       )
 
-      if(lbl) return(lablr(test, markdown)) else return(test)
+      if(lbl) {
+        test <- lablr(test, markdown)
+      }
+
+      class(test) <- c("writR", "list")
+
+      return(test)
     }
   }
   # Robust statistics
@@ -258,7 +282,7 @@ k_sample <- function(data, x, y,
         df.error = as.double(test$df2),
         p.value = test$p.value,
         method = "one-way repeated measures ANOVA for trimmed means",
-        alternative = as.character(NA),
+        alternative = NA_character_,
         estimate = es[[1L]],
         conf.level = 0.95,
         conf.low = es[[2L]],
@@ -267,7 +291,13 @@ k_sample <- function(data, x, y,
         n_obs = length(y_var) / length(x_lvl)
       )
 
-      if(lbl) return(lablr(test, markdown)) else return(test)
+      if(lbl) {
+        test <- lablr(test, markdown)
+      }
+
+      class(test) <- c("writR", "list")
+
+      return(test)
     # one-way ANOVA for trimmed means
     } else {
       test <- WRS2::t1way(
@@ -284,7 +314,7 @@ k_sample <- function(data, x, y,
         df.error = as.double(test$df2),
         p.value = test$p.value,
         method = "one-way ANOVA for trimmed means",
-        alternative = as.character(NA),
+        alternative = NA_character_,
         estimate = test$effsize,
         conf.level = 0.95,
         conf.low = test$effsize_ci[[1L]],
@@ -293,7 +323,13 @@ k_sample <- function(data, x, y,
         n_obs = length(y_var)
       )
 
-      if(lbl) return(lablr(test, markdown)) else return(test)
+      if(lbl) {
+        test <- lablr(test, markdown)
+      }
+
+      class(test) <- c("writR", "list")
+
+      return(test)
     }
   }
 }
diff --git a/R/lablr.R b/R/lablr.R
@@ -130,6 +130,9 @@ lablr <- function(t, markdown = FALSE) {
       ci = (.ci <- paste0(ci., format(round(t$conf.low, 2), nsmall = 2), ", ", format(round(t$conf.high, 2), nsmall = 2), "]")),
       full = paste(.p, .es, .ci, sep = ", ")
     )
+
+    class(res) <- c("writR", "list")
+
     return(res)
   }
   if(method == "Fisher's Exact Test for Count Data without OR") {
@@ -140,6 +143,9 @@ lablr <- function(t, markdown = FALSE) {
       ci = as.character(NA),
       full = .p
     )
+
+    class(res) <- c("writR", "list")
+
     return(res)
   }
 
@@ -160,5 +166,7 @@ lablr <- function(t, markdown = FALSE) {
     full = paste(.stats, .p, .es, .ci, sep = ", ")
   )
 
+  class(res) <- c("writR", "list")
+
   return(res)
 }
diff --git a/R/miscellaneous.R b/R/miscellaneous.R
@@ -86,15 +86,14 @@ is_normal <- function(x, alpha = 0.05, test = NULL) {
 #' @param x Grouping factor.
 #' @param alpha Threshold for null hipotesis (of normality) rejection.
 #' @param center A function to compute the center of each group; mean gives the original Levene's test; the default, median, provides a more robust test.
-#' @importFrom nortest lillie.test
 #' @importFrom stats complete.cases anova lm median
 #' @export
 
-is_var.equal <- function(y, x, alpha = 0.05, center = median) {
-  valid <- complete.cases(y, x)
+is_var.equal <- function(y, x, alpha = 0.05, center = stats::median) {
+  valid <- stats::complete.cases(y, x)
   meds <- tapply(y[valid], x[valid], center)
   resp <- abs(y - meds[x])
-  anova(lm(resp ~ x))[["Pr(>F)"]][[1]] > alpha
+  stats::anova(stats::lm(resp ~ x))[["Pr(>F)"]][[1]] > alpha
 }
 
 #' @title Mauchly's Test of Sphericity
@@ -197,6 +196,7 @@ HF <- function(model, gg = NULL) {
 #' @description Internal function inside `k_sample`. Return the Spherecity correction suggested based on Mauchly test in one-way repeated measures designs
 #'
 #' @param model A repeated measures ANOVA model using Afex.
+#' @export
 
 sphericity_check <- function(model) {
   .m <- model$Anova
@@ -206,3 +206,34 @@ sphericity_check <- function(model) {
     if(is_hf || is_hf_too) "HF" else "GG"
   }
 }
+
+#' @title Print method for writR objects
+#' @name print.writR
+#' @param x A writR object from any of one_sample, two_sample, k_sample, autest or contingency.
+#' @param ... Currently ignored
+#' @importFrom data.table as.data.table
+#' @export
+
+print.writR <- function(x, ...) {
+  x <- data.table::as.data.table(
+    x = x[!sapply(x, anyNA)]
+  )
+  print(x)
+}
+
+#' @title as.data.frame method for writR objects
+#' @name as.data.frame.writR
+#' @param x A writR object from any of one_sample, two_sample, k_sample, autest or contingency.
+#' @param row.names Exported from other methods.
+#' @param optional Exported from other methods.
+#' @param ... Currently ignored
+#' @export
+
+as.data.frame.writR <- function(x, row.names = NULL, optional = FALSE, ...) {
+  as.data.frame(
+    x = x[!sapply(x, anyNA)],
+    row.names = row.names,
+    optional = optional
+  )
+}
+