tests/testthat/test-impute-below.R

In njtierney/ggmissing: Data Structures, Summaries, and Visualisations for Missing Data

test_that("impute_below returns NULL when given NULL", {
  expect_null(impute_below(NULL))
})

test_that("impute_below returns an error when given the wrong kind of object", {
  expect_snapshot(
    error = TRUE,
    impute_below(3i)
  )
})

miss_vec_5 <- c(10, 10, 9, NA, 3)

test_that("impute_below returns NA values less than minimum for one location", {
  expect_lt(
    impute_below(miss_vec_5)[which_na(miss_vec_5)],
    min(miss_vec_5, na.rm = TRUE)
  )
})

miss_vec_2 <- c(4, NA)
miss_vec_3 <- c(4, NA, NA)
miss_vec_4 <- c(4, NA, NA, NA)

test_that("impute_below returns NA values less than min when only one missing value", {
  expect_lt(
    impute_below(miss_vec_2)[which_na(miss_vec_2)],
    min(miss_vec_2, na.rm = TRUE)
  )
  expect_lt(
    min(impute_below(miss_vec_3)[which_na(miss_vec_3)]),
    min(miss_vec_3, na.rm = TRUE)
  )
  expect_lt(
    min(impute_below(miss_vec_4)[which_na(miss_vec_4)]),
    min(miss_vec_4, na.rm = TRUE)
  )
})

miss_vec <- rnorm(100)

# add 20 missing values
miss_vec[sample(1:100, 20)] <- NA

test_that("impute_below returns NA values less than min for many locations", {
  expect_lt(
    min(impute_below(miss_vec)[which_na(miss_vec)]),
    min(miss_vec, na.rm = TRUE)
  )
})

test_that("impute_below returns the same input when length == 1", {
  expect_equal(impute_below(1), 1)
})

test_vec <- runif(100)
test_that("impute_below returns same input when there are no missing values", {
  expect_equal(impute_below(test_vec), test_vec)
})

# need to add tests for test-success for new classes supported by impute_below

# expect_error(impute_below("c"))
# expect_error(impute_below(iris$Species))

test_that("impute_below prop_below makes shifts bigger", {
  expect_gt(
    min(impute_below(miss_vec)[which_na(miss_vec)]),
    min(impute_below(miss_vec, prop_below = 0.2)[which_na(miss_vec)])
  )
})

test_that("impute_below prop_below makes shifts bigger", {
  expect_gt(
    min(impute_below(miss_vec, prop_below = 0.2)[which_na(miss_vec)]),
    min(impute_below(miss_vec, prop_below = 0.4)[which_na(miss_vec)])
  )
})

test_that("impute_below jitter makes shifts bigger", {
  expect_lt(
    var(impute_below(miss_vec)[which_na(miss_vec)]),
    var(impute_below(miss_vec, jitter = 0.2)[which_na(miss_vec)])
  )
})

test_that("impute_below jitter makes shifts bigger", {
  expect_lt(
    var(impute_below(miss_vec, jitter = 0.2)[which_na(miss_vec)]),
    var(impute_below(miss_vec, jitter = 0.4)[which_na(miss_vec)])
  )
})

df_inf <- data.frame(x = c(-Inf, rnorm(2), NA, Inf))

test_that("missing values are replaced in shadow shift", {
  expect_false(anyNA(impute_below(df_inf$x)))
})

test_that("infinite values are maintained in shadow shift", {
  expect_equal(sum(is.infinite(impute_below(df_inf$x))), 2)
})

library(dplyr)

dat_date <- tibble::tibble(
  values = 1:7,
  number = c(111, 112, NA, NA, 108, 150, 160),
  posixct = as.POSIXct(number, origin = "1970-01-01"),
  posixlt = as.POSIXlt(number, origin = "1970-01-01"),
  date = as.Date(number)
)

test_that("dates are imputed", {
  expect_false(anyNA(impute_below(dat_date$posixct)))
  expect_false(anyNA(impute_below(dat_date$posixlt)))
  expect_false(anyNA(impute_below(dat_date$date)))
})


toy_data <- data.frame(
  x = c(1, 2, 3, NA, NA, NA, 7, 8, 9),
  y = c(LETTERS[1:7], NA, NA),
  z = c(NA, NA, rnorm(6), NA)
)

test_that("impute_below_all returns NULL when given NULL", {
  expect_equal(impute_below_all(data.frame(NULL)), data.frame(NULL))
})

test_that("impute_below_all errors when given wrong object", {
  expect_snapshot(
    error = TRUE,
    impute_below_all(as.POSIXct(111, origin = "1970-01-01"))
  )
})

miss_vec_5 <- c(10, 10, 9, NA, 3)

test_that("impute_below_all returns NA values less than min for one location", {
  expect_lt(
    impute_below_all(data.frame(miss_vec_5))[which_na(miss_vec_5), ],
    min(miss_vec_5, na.rm = TRUE)
  )
})

miss_vec_2 <- data.frame(x = c(4, NA))
miss_vec_4 <- data.frame(x = c(4, NA, NA, NA))

test_that("impute_below_all returns NA values < min when only one missing", {
  expect_lt(
    impute_below_all(miss_vec_2)[which_na(miss_vec_2), ],
    min(miss_vec_2, na.rm = TRUE)
  )
  expect_lt(
    min(impute_below_all(miss_vec_4)[which_na(miss_vec_4), ]),
    min(miss_vec_4, na.rm = TRUE)
  )
})

miss_vec <- data.frame(x = rnorm(100))

# add 20 missing values
miss_vec[sample(1:100, 20), ] <- NA

test_that("impute_below_all returns NA values less than min for many locations", {
  expect_lt(
    min(impute_below_all(miss_vec)[which_na(miss_vec), ]),
    min(miss_vec, na.rm = TRUE)
  )
})

test_that("impute_below_all returns the same input when length == 1", {
  expect_equal(impute_below_all(data.frame(1)), data.frame(1))
})

test_vec <- data.frame(x = runif(100))
test_that("impute_below_all returns same input when no missings", {
  expect_equal(impute_below_all(test_vec), test_vec)
})


miss_vec <- rnorm(100)

# add 20 missing values
miss_vec[sample(1:100, 20)] <- NA

miss_df <- data.frame(miss_vec)

test_that("impute_below_all leaves no NA values", {
  expect_false(
    anyNA(impute_below_all(miss_df)[which_na(miss_df$miss_vec), ])
  )
})

test_that("impute_below_all prop_below makes shifts bigger", {
  expect_gt(
    min(impute_below_all(miss_df)[which_na(miss_df$miss_vec), ]),
    min(impute_below_all(miss_df, prop_below = 0.3)[
      which_na(miss_df$miss_vec),
    ])
  )
})

test_that("impute_below_all prop_below makes shifts bigger", {
  expect_gt(
    min(impute_below_all(miss_df, prop_below = 0.2)[
      which_na(miss_df$miss_vec),
    ]),
    min(impute_below_all(miss_df, prop_below = 0.4)[
      which_na(miss_df$miss_vec),
    ])
  )
})

test_that("impute_below_all jitter makes shifts bigger", {
  expect_lt(
    var(impute_below_all(miss_df)[which_na(miss_df$miss_vec), ]),
    var(impute_below_all(miss_df, jitter = 0.2)[which_na(miss_df$miss_vec), ])
  )
})

test_that("impute_below_all jitter makes shifts bigger", {
  expect_lt(
    var(impute_below_all(miss_df, jitter = 0.2)[which_na(miss_df$miss_vec), ]),
    var(impute_below_all(miss_df, jitter = 0.4)[which_na(miss_df$miss_vec), ])
  )
})

aq_s <- nabular(airquality)

test_that("impute_below works with nabular", {
  expect_type(impute_below(aq_s$Ozone), "double")
  expect_s3_class(impute_below_all(aq_s), "data.frame")
  expect_s3_class(
    impute_below_at(aq_s, dplyr::vars(Ozone, Solar.R)),
    "data.frame"
  )
  expect_s3_class(impute_below_if(aq_s, is.numeric), "data.frame")
})