add tests

NAMESPACE

@@ -73,3 +73,7 @@ export(standardize)
 export(to_numeric)
 export(unstandardize)
 export(winsorize)
+importFrom(stats,mad)
+importFrom(stats,median)
+importFrom(stats,sd)
+importFrom(stats,weighted.mean)

R/check_if_installed.R

@@ -0,0 +1,35 @@
+#' Checking if needed package is installed
+
+#' @param package A string naming the package, whose installation needs to be
+#'   checked in any of the libraries
+#' @param reason A phrase describing why the package is needed. The default is a
+#'   generic description.
+#' @param stop Logical that decides whether the function should stop if the
+#'   needed package is not installed.
+#' @param ... Currently ignored
+#'
+#' @examples
+#' \dontrun{
+#'   check_if_installed("inexistent_package")
+#' }
+#'
+#'
+#' @export
+
+check_if_installed <- function(package,
+                               reason = "for this function to work",
+                               stop = TRUE,
+                               ...) {
+  # does it need to be displayed?
+  is_installed <- requireNamespace(package, quietly = TRUE)
+  if (!is_installed) {
+    # prepare the message
+    message <- paste0(
+      "Package '", package, "' is required ", reason, ".\n",
+      "Please install it by running install.packages('", package, "')."
+    )
+
+    if (stop) stop(message, call. = FALSE) else warning(message, call. = FALSE)
+  }
+  invisible(is_installed)
+}

R/utils_standardize.R

@@ -0,0 +1,121 @@
+
+# For standardize_parameters ----------------------------------------------
+
+#' @keywords internal
+.get_object <- function(x, attribute_name = "object_name") {
+  obj_name <- attr(x, attribute_name, exact = TRUE)
+  model <- NULL
+  if (!is.null(obj_name)) {
+    model <- tryCatch(
+      {
+        get(obj_name, envir = parent.frame())
+      },
+      error = function(e) {
+        NULL
+      }
+    )
+    if (is.null(model) ||
+      # prevent self reference
+      inherits(model, "parameters_model")) {
+      model <- tryCatch(
+        {
+          get(obj_name, envir = globalenv())
+        },
+        error = function(e) {
+          NULL
+        }
+      )
+    }
+  }
+  model
+}
+
+
+
+# For standardize_info ----------------------------------------------------
+
+#' @keywords internal
+#' @importFrom stats weighted.mean
+.mean <- function(x, weights = NULL) {
+  if (!.are_weights(weights)) {
+    return(mean(x, na.rm = TRUE))
+  }
+
+  stopifnot(all(weights > 0, na.rm = TRUE))
+
+  stats::weighted.mean(x, weights, na.rm = TRUE)
+}
+
+#' @keywords internal
+#' @importFrom stats sd
+.sd <- function(x, weights = NULL) {
+  # from cov.wt
+  if (!.are_weights(weights)) {
+    return(stats::sd(x, na.rm = TRUE))
+  }
+
+  stopifnot(all(weights > 0, na.rm = TRUE))
+
+  weights1 <- weights / sum(weights)
+  center <- sum(weights1 * x)
+  xc <- sqrt(weights1) * (x - center)
+  var <- (t(xc) %*% xc) / (1 - sum(weights1^2))
+  sqrt(as.vector(var))
+}
+
+
+
+#' @keywords internal
+#' @importFrom stats mad
+.mad <- function(x, weights = NULL, constant = 1.4826) {
+  # From matrixStats
+  if (!.are_weights(weights)) {
+    return(stats::mad(x, na.rm = TRUE))
+  }
+
+  stopifnot(all(weights > 0, na.rm = TRUE))
+
+  center <- .median(x, weights = weights)
+  x <- abs(x - center)
+  constant * .median(x, weights = weights)
+}
+
+
+
+#' @keywords internal
+#' @importFrom stats median
+.median <- function(x, weights = NULL) {
+  # From spatstat + wiki
+  if (!.are_weights(weights)) {
+    return(stats::median(x, na.rm = TRUE))
+  }
+
+  stopifnot(all(weights > 0, na.rm = TRUE))
+
+  oo <- order(x)
+  x <- x[oo]
+  weights <- weights[oo]
+  Fx <- cumsum(weights) / sum(weights)
+
+  lefties <- which(Fx <= 0.5)
+  left <- max(lefties)
+  if (length(lefties) == 0) {
+    result <- x[1]
+  } else if (left == length(x)) {
+    result <- x[length(x)]
+  } else {
+    result <- x[left]
+
+    if (!(Fx[left - 1] < 0.5 && 1 - Fx[left] < 0.5)) {
+      right <- left + 1
+      y <- x[left] * Fx[left] + x[right] * Fx[right]
+      if (is.finite(y)) result <- y
+    }
+  }
+
+  return(result)
+}
+
+.are_weights <- function(w) {
+  !is.null(w) && length(w) && !all(w == 1) && !all(w == w[1])
+}

datawizard.Rproj

@@ -1,8 +1,8 @@
 Version: 1.0
 
-RestoreWorkspace: Default
-SaveWorkspace: Default
-AlwaysSaveHistory: Default
+RestoreWorkspace: No
+SaveWorkspace: No
+AlwaysSaveHistory: No
 
 EnableCodeIndexing: Yes
 UseSpacesForTab: Yes
@@ -19,3 +19,6 @@ BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
 PackageRoxygenize: rd,collate,namespace
+
+QuitChildProcessesOnExit: Yes
+DisableExecuteRprofile: Yes

tests/testthat/test-adjust.R

@@ -0,0 +1,21 @@
+if (require("testthat") && require("effectsize")) {
+  data(iris)
+  test_that("adjust multilevel", {
+    skip_if_not_installed("lme4")
+    adj <- adjust(iris[c("Sepal.Length", "Species")], multilevel = TRUE, bayesian = FALSE)
+    expect_equal(
+      head(adj$Sepal.Length),
+      c(0.08698, -0.11302, -0.31302, -0.41302, -0.01302, 0.38698),
+      tolerance = 1e-3
+    )
+  })
+
+  test_that("adjust", {
+    adj <- adjust(iris[c("Sepal.Length", "Species")], multilevel = FALSE, bayesian = FALSE)
+    expect_equal(
+      head(adj$Sepal.Length),
+      c(0.094, -0.106, -0.306, -0.406, -0.006, 0.394),
+      tolerance = 1e-3
+    )
+  })
+}

tests/testthat/test-ranktransform.R

@@ -0,0 +1,16 @@
+if (require("testthat") && require("effectsize")) {
+  test_that("signed rank", {
+    x <- c(-1, 2, -3, 4)
+
+    sr <- ranktransform(x, sign = TRUE)
+    r <- ranktransform(x, sign = FALSE)
+
+    expect_equal(sr, x) # unchanged
+    expect_equal(r, c(2, 3, 1, 4))
+
+
+    x <- c(1, -2, -2, 4, 0, 3, -14, 0)
+    expect_warning(ranktransform(x, sign = TRUE))
+    expect_true(all(is.na(suppressWarnings(ranktransform(x, sign = TRUE)[c(5, 8)]))))
+  })
+}