Merge pull request #309 from njtierney/add-random-missingness-298

Implemented `set_n_miss` and `set_prop_miss`

DESCRIPTION

@@ -73,7 +73,9 @@ Imports:
  forcats,
  viridis,
  glue,
- UpSetR
+ UpSetR,
+ cli,
+ vctrs
 Collate:
  'add-cols.R'
  'add-n-prop-miss.R'
@@ -118,6 +120,7 @@ Collate:
  'replace-to-na.R'
  'replace-with-na.R'
  'scoped-replace-with-na.R'
+ 'set-n-prop-miss.R'
  'shade.R'
  'shadow-recode.R'
  'shadow-shifters.R'

NAMESPACE

@@ -133,6 +133,8 @@ export(replace_with_na)
 export(replace_with_na_all)
 export(replace_with_na_at)
 export(replace_with_na_if)
+export(set_n_miss)
+export(set_prop_miss)
 export(shade)
 export(shadow_long)
 export(shadow_shift)

NEWS.md

@@ -1,5 +1,12 @@
 # naniar 0.6.1.9000
 
+## New
+
+- The DOI in the CITATION is for a new JSS publication that will be registered 
+ after publication on CRAN.
+- Replaced `tidyr::gather` with `tidyr::pivot_longer` - resolves #301
+- added `set_n_miss` and `set_prop_miss` functions - resolved #298
+
 ## Bug Fixes
 
 - Fix bug in `gg_miss_var()` where a warning appears to due change in how to 
@@ -8,9 +15,8 @@ remove legend [#288](https://github.com/njtierney/naniar/issues/288).
 ## Misc
 
 - Removed gdtools from naniar as no longer needed [302](https://github.com/njtierney/naniar/issues/302).
-- The DOI in the CITATION is for a new JSS publication that will be registered 
- after publication on CRAN.
-- Replaced `tidyr::gather` with `tidyr::pivot_longer` - resolves #301
+- added imports, `vctrs` and `cli` - which are both free dependencies as they
+ are used within the already used tidyverse already.
 
 # naniar 0.6.1 (2021/05/13) "Incandescent lightbulbs killed the Arc lamps"
 

R/set-n-prop-miss.R

@@ -0,0 +1,31 @@
+#' Set a proportion or number of missing values
+#'
+#' @param x vector of values to set missing
+#' @param prop proportion of values between 0 and 1 to set as missing
+#'
+#' @return vector with missing values added
+#' @name set-prop-n-miss
+#'
+#' @examples
+#' vec <- rnorm(5)
+#' set_prop_miss(vec, 0.2)
+#' set_prop_miss(vec, 0.4)
+#' set_n_miss(vec, 1)
+#' set_n_miss(vec, 4)
+#' @export
+set_prop_miss <- function(x, prop = 0.1) {
+ check_is_scalar(prop)
+ check_btn_0_1(prop)
+ x[sample(seq_along(x) <= prop * length(x))] <- NA
+ x
+}
+
+#' @rdname set-prop-n-miss
+#' @param n number of values to set missing
+#' @export
+set_n_miss <- function(x, n = 1) {
+ check_is_scalar(n)
+ check_is_integer(n)
+ x[sample(seq_along(x) <= n)] <- NA
+ x
+}

R/utils.R

@@ -205,3 +205,37 @@ any_row_shade <- function(x){
 vecIsFALSE <- Vectorize(isFALSE)
 
 are_any_false <- function(x, ...) any(vecIsFALSE(x), ...)
+
+check_btn_0_1 <- function(prop){
+ if (prop < 0 || prop > 1) {
+ cli::cli_abort(
+ c(
+ "{.var prop} must be between 0 and 1",
+ "{.var prop} is {prop}"
+ )
+ )
+ }
+}
+
+check_is_integer <- function(x){
+ if (x < 0) {
+ cli::cli_abort(
+ c(
+ "{.var x} must be greater than 0",
+ "{.var x} is {x}"
+ )
+ )
+ }
+ vctrs::vec_cast(x, integer())
+}
+
+check_is_scalar <- function(x){
+ if (length(x) != 1) {
+ cli::cli_abort(
+ c(
+ "{.var x} must be length 1",
+ "{.var x} is {x}, and {.var x} has length: {length(x)}"
+ )
+ )
+ }
+}

tests/testthat/_snaps/set-n-prop-miss.md

@@ -0,0 +1,39 @@
+# set_n_miss errors appropriately
+
+ `x` must be greater than 0
+ `x` is -1
+
+---
+
+ Can't convert `x` <character> to <integer>.
+
+---
+
+ Can't convert from `x` <double> to <integer> due to loss of precision.
+ * Locations: 1
+
+---
+
+ `x` must be length 1
+ `x` is 1.5 and 2, and `x` has length: 2
+
+# set_prop_miss errors appropriately
+
+ `prop` must be between 0 and 1
+ `prop` is -1
+
+---
+
+ `prop` must be between 0 and 1
+ `prop` is a
+
+---
+
+ `prop` must be between 0 and 1
+ `prop` is 1.5
+
+---
+
+ `x` must be length 1
+ `x` is 1.5 and 2, and `x` has length: 2
+

tests/testthat/test-set-n-prop-miss.R

@@ -0,0 +1,45 @@
+vec <- 1:10
+
+test_that("set_n_miss works", {
+ expect_equal(n_miss(set_n_miss(vec, 1)), 1)
+ expect_equal(n_miss(set_n_miss(vec, 5)), 5)
+ expect_equal(n_miss(set_n_miss(vec, 10)), 10)
+ expect_equal(n_miss(set_n_miss(vec, 0)), 0)
+})
+
+test_that("set_prop_miss works", {
+ expect_equal(prop_miss(set_prop_miss(vec, 0.1)), .1)
+ expect_equal(prop_miss(set_prop_miss(vec, 0.5)), .5)
+ expect_equal(prop_miss(set_prop_miss(vec, 1)), 1)
+ expect_equal(prop_miss(set_prop_miss(vec, 0)), 0)
+})
+
+test_that("set_n_miss errors appropriately", {
+ expect_snapshot_error(
+ set_n_miss(vec, -1)
+ )
+ expect_snapshot_error(
+ set_n_miss(vec, "a")
+ )
+ expect_snapshot_error(
+ set_n_miss(vec, 1.5)
+ )
+ expect_snapshot_error(
+ set_n_miss(vec, c(1.5, 2))
+ )
+})
+
+test_that("set_prop_miss errors appropriately", {
+ expect_snapshot_error(
+ set_prop_miss(vec, -1)
+ )
+ expect_snapshot_error(
+ set_prop_miss(vec, "a")
+ )
+ expect_snapshot_error(
+ set_prop_miss(vec, 1.5)
+ )
+ expect_snapshot_error(
+ set_prop_miss(vec, c(1.5, 2))
+ )
+})