tests/testthat/test-utils.R

In mikropml: User-Friendly R Package for Supervised Machine Learning Pipelines

options(warnPartialMatchArgs = FALSE)
# Without this, underlying code in either stats or base R causes this warning in several places:
#   warning: get_predictions works
#   partial argument match of 'contrasts' to 'contrasts.arg'

test_df <- data.frame(
  outcome = c("normal", "normal", "cancer"),
  var1 = 1:3,
  var2 = 4:6
)

test_that("split_outcome_features works", {
  expect_equal(
    split_outcome_features(test_df, "outcome"),
    list(
      outcome = data.frame(outcome = c("normal", "normal", "cancer")),
      features = data.frame(
        var1 = 1:3,
        var2 = 4:6
      )
    )
  )
})

test_that("randomize_feature_order works for known seed", {
  reordered_df <- data.frame(
    outcome = c("normal", "normal", "cancer"),
    var2 = 4:6,
    var1 = 1:3
  )
  set.seed(20)
  expect_equal(
    randomize_feature_order(test_df, "outcome"),
    reordered_df
  )
})

test_that("check if correct apply is selected", {
  fa_installed <- all(check_packages_installed("future.apply"))
  if (fa_installed) {
    expect_equal(select_apply("lapply"), future.apply::future_lapply)
    expect_equal(select_apply("sapply"), future.apply::future_sapply)
    expect_equal(select_apply("apply"), future.apply::future_apply)
  } else {
    expect_equal(select_apply("lapply"), lapply)
    expect_equal(select_apply("sapply"), sapply)
    expect_equal(select_apply("apply"), apply)
  }
})

test_that("mutate_all_types converts factors to other types", {
  dat1 <- data.frame(
    c1 = as.factor(c("a", "b", "c")),
    c2 = as.factor(1:3),
    c3 = as.factor(c(1.1, 1.2, 1.3))
  )
  dat2 <- mutate_all_types(dat1)
  expect_equal(class(dat2$c1), "character")
  expect_equal(class(dat2$c2), "integer")
  expect_equal(class(dat2$c3), "numeric")
})

test_that("replace_spaces works", {
  expect_equal(
    replace_spaces(c("outcome 1", "outcome 2", "outcome 1")),
    c("outcome_1", "outcome_2", "outcome_1")
  )
  expect_equal(
    replace_spaces(c("no_spaces_here", "none")),
    c("no_spaces_here", "none")
  )
})

test_that("replace_spaces() doesn't modify non-character vectors", {
  x <- 1:3
  expect_equal(replace_spaces(x), x)
  y <- c(1.1, 2.2, 3.3)
  expect_equal(replace_spaces(y), y)
})

test_that("pbtick() updates the progress bar", {
  f <- function() {
    pb <- progressr::progressor(steps = 5)
    pbtick(pb, message = "progress!")
  }
  expect_condition(expect_invisible(f()))
})

test_that("radix_sort() order is stable regardless of locale", {
  locale <- Sys.getlocale("LC_COLLATE")
  invisible(Sys.setlocale("LC_COLLATE", "en_US.UTF-8"))
  sort_enus <- radix_sort(c(letters, LETTERS))
  invisible(Sys.setlocale("LC_COLLATE", "C"))
  sort_c <- radix_sort(c(letters, LETTERS))

  expect_equal(sort_enus, sort_c)

  invisible(Sys.setlocale("LC_COLLATE", locale))
})

test_that("is_whole_number() checks for integer numbers regardless of class", {
  expect_true(all(is_whole_number(c(1, 2, 3))))
  expect_false(is.integer(1))
  expect_true(all(is_whole_number(c(1.0, 2.0, 3.0))))
  expect_false(is_whole_number(1.2))
})

test_that("calc_pvalue() works", {
  set.seed(123)
  expect_equal(round(calc_pvalue(1:20, 10), digits = 3), 0.571)
  expect_equal(calc_pvalue(c(1, 1, 1), 2), 0.25)
  expect_equal(calc_pvalue(1:3, 0), 1)
})