add sparse_var()

NAMESPACE

@@ -22,5 +22,6 @@ export(sparse_logical)
 export(sparse_mean)
 export(sparse_positions)
 export(sparse_values)
+export(sparse_var)
 import(rlang)
 useDynLib(sparsevctrs, .registration = TRUE)

NEWS.md

@@ -1,6 +1,6 @@
 # sparsevctrs (development version)
 
-* Helper function `sparse_mean()` has been added. (#49)
+* Helper functions `sparse_mean()` and `sparse_var()` has been added. (#49)
 
 * All sparse vector types now have a significant smaller base object size. (#67)
 

R/sparse_mean.R

@@ -1,7 +1,5 @@
 #' Calculate mean from sparse vectors
 #' 
-#' Helper functions to determine whether an vector is a sparse vector or not.
-#' 
 #' @param x A sparse numeric vector.
 #' @param na_rm Logical, whether to remove missing values. Defaults to `FALSE`.
 #' 

R/sparse_var.R

@@ -0,0 +1,64 @@
+#' Calculate variance from sparse vectors
+#' 
+#' @param x A sparse numeric vector.
+#' @param na_rm Logical, whether to remove missing values. Defaults to `FALSE`.
+#' 
+#' @details
+#' This function, as with any of the other helper functions assumes that the
+#' input `x` is a sparse numeric vector. This is done for performance reasons,
+#' and it is thus the users responsibility to perform input checking.
+#' 
+#' Much like [var()] it uses the denominator `n-1`.
+#'
+#' @return single numeric value.
+#' 
+#' @examples
+#' sparse_var(
+#'   sparse_double(1000, 1, 1000)
+#' )
+#' 
+#' sparse_var(
+#'   sparse_double(1000, 1, 1000, default = 1)
+#' )
+#' 
+#' sparse_var(
+#'   sparse_double(c(10, 50, 11), c(1, 50, 111), 1000)
+#' )
+#' 
+#' sparse_var(
+#'   sparse_double(c(10, NA, 11), c(1, 50, 111), 1000)
+#' )
+#' 
+#' sparse_var(
+#'   sparse_double(c(10, NA, 11), c(1, 50, 111), 1000),
+#'   na_rm = TRUE
+#' )
+#' 
+#' @export
+sparse_var <- function(x, na_rm = FALSE) {
+  values <- sparse_values(x)
+  len_values <- length(values)
+
+  if (len_values == 0) {
+    return(0)
+  }
+
+  default <- sparse_default(x)
+  x_len <- length(x)
+
+  mean <- sparse_mean(x, na_rm = na_rm)
+
+  res <- sum((values - mean) ^ 2, na.rm = na_rm)
+
+
+  res <- res + (default - mean) ^ 2 * (x_len - len_values)
+
+  denominator <- x_len - 1
+
+  if (na_rm) {
+    denominator <- denominator - sum(is.na(values))
+  }
+
+  res <- res / denominator
+  res
+}

_pkgdown.yml

@@ -29,6 +29,7 @@ reference:
   - title: Helper Functions
     contents:
     - sparse_mean
+    - sparse_var
 
   - title: Utility Functions
     contents:

tests/testthat/test-sparse_var.R

@@ -0,0 +1,37 @@
+test_that("sparse_var() works", {
+  x <- sparse_double(10, 5, 1000)
+
+  expect_equal(var(x), sparse_var(x))
+
+  x <- sparse_double(c(10, -10), c(5, 100), 1000)
+
+  expect_equal(var(x), sparse_var(x))
+
+  x <- sparse_double(c(10, -10), c(5, 100), 1000, default = 20)
+
+  expect_equal(var(x), sparse_var(x))
+
+  x <- sparse_double(c(NA, 10, 30), 1:3, 1000)
+
+  expect_equal(var(x), sparse_var(x))
+
+  x <- sparse_double(c(NA, 10, 30), 1:3, 1000, default = 100)
+
+  expect_equal(var(x), sparse_var(x))
+
+  x <- sparse_double(c(NA, 10, 30), 1:3, 1000)
+
+  expect_equal(var(x, na.rm = TRUE), sparse_var(x, na_rm = TRUE))
+
+  x <- sparse_double(c(NA, 10, 30), 1:3, 1000, default = 100)
+
+  expect_equal(var(x, na.rm = TRUE), sparse_var(x, na_rm = TRUE))
+
+  x <- sparse_double(numeric(), integer(), 1000)
+
+  expect_equal(var(x), sparse_var(x))
+
+  x <- sparse_double(numeric(), integer(), 1000, default = 100)
+
+  expect_equal(var(x), sparse_var(x))
+})