-
Notifications
You must be signed in to change notification settings - Fork 12
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #160 from DavisVaughan/summary-group
Summary group
- Loading branch information
Showing
7 changed files
with
238 additions
and
55 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,58 @@ | ||
| # Summary generics are: | ||
| # - all(), any() | ||
| # - sum(), prod() | ||
| # - min(), max() | ||
| # - range() | ||
|
|
||
| # All of them dispatch on the first argument, as described in `?Summary` | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
|
|
||
| # - vctrs:::min.vctrs_vctr() does the right thing because of `xtfrm.vctrs_vctr()` | ||
| # - vctrs:::max.vctrs_vctr() does the right thing because of `xtfrm.vctrs_vctr()` | ||
|
|
||
| # However, vctrs only automatically implements `xtfrm()` for integer and double | ||
| # arrays, so logical ones need special treatment. Because of this, just | ||
| # implement a simple xtfrm() method that calls `vec_proxy_compare()` like vctrs | ||
|
|
||
| #' @export | ||
| xtfrm.vctrs_rray <- function(x) { | ||
| vec_proxy_compare(x) | ||
| } | ||
|
|
||
| #' @export | ||
| xtfrm.vctrs_rray_lgl <- function(x) { | ||
| rray_cast_inner(vec_proxy_compare(x), integer()) | ||
| } | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
|
|
||
| # This is a base R compatible version of `all()` and `any()`. | ||
| # It is used in vec_math() dispatch | ||
|
|
||
| # Note that `vctrs:::Summary.vctrs_vctr()` is how this is passed through, | ||
| # and `na.rm = TRUE` no matter what there! | ||
|
|
||
| rray_all_vctrs_wrapper <- function(x, na.rm) { | ||
| vec_math_base("all", vec_data(x), na.rm = na.rm) | ||
| } | ||
|
|
||
| rray_any_vctrs_wrapper <- function(x, na.rm) { | ||
| vec_math_base("any", vec_data(x), na.rm = na.rm) | ||
| } | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
|
|
||
| rray_range_vctrs_wrapper <- function(x, na.rm) { | ||
| vec_math_base("range", vec_data(x), na.rm = na.rm) | ||
| } | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
|
|
||
| rray_prod_vctrs_wrapper <- function(x, na.rm) { | ||
| vec_math_base("prod", vec_data(x), na.rm = na.rm) | ||
| } | ||
|
|
||
| rray_sum_vctrs_wrapper <- function(x, na.rm) { | ||
| vec_math_base("sum", vec_data(x), na.rm = na.rm) | ||
| } |
Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,166 @@ | ||
| # ------------------------------------------------------------------------------ | ||
| context("test-xtfrm") | ||
|
|
||
| test_that("xtfrm() returns proxy objects", { | ||
| x <- rray(1:2, c(2, 1)) | ||
| expect_equal(xtfrm(x), vec_data(x)) | ||
|
|
||
| x <- rray(c(1, 2), c(2, 1)) | ||
| expect_equal(xtfrm(x), vec_data(x)) | ||
| }) | ||
|
|
||
| test_that("xtfrm() works for 3D", { | ||
| x <- rray(1:6, c(2, 1, 3)) | ||
| expect_equal(xtfrm(x), vec_data(x)) | ||
| }) | ||
|
|
||
| test_that("xtfrm() for logicals returns integers", { | ||
| x <- rray(c(TRUE, FALSE), c(2, 1)) | ||
| expect_equal(xtfrm(x), new_matrix(c(1, 0), c(2, 1))) | ||
| }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-min") | ||
|
|
||
| test_that("`min()` returns a length 1 vector for 1D", { | ||
| expect_equal(min(rray(5:1)), rray(1L)) | ||
| expect_equal(min(rray(5:1 + 0)), rray(1)) | ||
| }) | ||
|
|
||
| test_that("`min()` returns a length 1 vector for 2D", { | ||
| x <- rray(c(2, 4, 5, 2), c(2, 2)) | ||
| expect_equal( | ||
| min(x), | ||
| rray(2) | ||
| ) | ||
| }) | ||
|
|
||
| test_that("`min()` returns a length 1 vector for 3D", { | ||
| x <- rray(c(2, 4, 5, 2), c(2, 1, 2)) | ||
| expect_equal( | ||
| min(x), | ||
| rray(2) | ||
| ) | ||
| }) | ||
|
|
||
| test_that("vctrs `min()` ignores input in `...`", { | ||
| expect_equal(min(rray(2), 1), rray(2)) | ||
| }) | ||
|
|
||
| # TODO - Add tests after this is fixed | ||
| # https://github.com/r-lib/vctrs/pull/329 | ||
|
|
||
| # test_that("NAs are removed", { | ||
| # min(rray(c(NA, 2)), na.rm = TRUE) | ||
| # }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-max") | ||
|
|
||
| test_that("`max()` returns a length 1 vector for 1D", { | ||
| expect_equal(max(rray(5:1)), rray(5L)) | ||
| expect_equal(max(rray(5:1 + 0)), rray(5)) | ||
| }) | ||
|
|
||
| test_that("`max()` returns a length 1 vector for 2D", { | ||
| x <- rray(c(2, 4, 5, 2), c(2, 2)) | ||
| expect_equal( | ||
| max(x), | ||
| rray(5) | ||
| ) | ||
| }) | ||
|
|
||
| test_that("`max()` returns a length 1 vector for 3D", { | ||
| x <- rray(c(2, 4, 5, 2), c(2, 1, 2)) | ||
| expect_equal( | ||
| max(x), | ||
| rray(5) | ||
| ) | ||
| }) | ||
|
|
||
| test_that("vctrs `max()` ignores input in `...`", { | ||
| expect_equal(max(rray(2), 1), rray(2)) | ||
| }) | ||
|
|
||
| # TODO - Add tests after this is fixed | ||
| # https://github.com/r-lib/vctrs/pull/329 | ||
|
|
||
| # test_that("NAs are removed", { | ||
| # max(rray(c(NA, 2)), na.rm = TRUE) | ||
| # }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-base-any") | ||
|
|
||
| test_that("returns a single value with shaped arrays", { | ||
| expect_equal(any(rray(c(TRUE, FALSE), c(2, 2))), TRUE) | ||
| expect_equal(any(rray(c(FALSE, FALSE), c(2, 2))), FALSE) | ||
| }) | ||
|
|
||
| test_that("always uses `na.rm = TRUE`", { | ||
| expect_equal(any(rray(c(NA, 1L)), na.rm = FALSE), TRUE) | ||
| expect_equal(any(rray(c(NA, 0L)), na.rm = FALSE), FALSE) | ||
| }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-base-all") | ||
|
|
||
| test_that("returns a single value with shaped arrays", { | ||
| expect_equal(all(rray(c(TRUE, FALSE), c(2, 2))), FALSE) | ||
| expect_equal(all(rray(c(TRUE, TRUE), c(2, 2))), TRUE) | ||
| }) | ||
|
|
||
| test_that("always uses `na.rm = TRUE`", { | ||
| expect_equal(all(rray(c(NA, 1L, 0L)), na.rm = FALSE), FALSE) | ||
| expect_equal(all(rray(c(NA, 1L, 1L)), na.rm = FALSE), TRUE) | ||
| }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-base-range") | ||
|
|
||
| test_that("returns same values as base R", { | ||
| x <- rray(c(TRUE, FALSE), c(2, 2)) | ||
| expect_equal(range(x), range(vec_data(x))) | ||
| expect_equal(range(x, x), range(vec_data(x), vec_data(x))) | ||
| expect_equal(range(x, 5), range(vec_data(x), 5)) | ||
| }) | ||
|
|
||
| test_that("always uses `na.rm = TRUE`", { | ||
| expect_equal(range(rray(c(NA, 1L)), na.rm = FALSE), c(1L, 1L)) | ||
| }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-base-prod") | ||
|
|
||
| test_that("returns same values as base R", { | ||
| x <- rray(c(5, 6), c(2, 2)) | ||
| expect_equal(prod(x), prod(vec_data(x))) | ||
| expect_equal(prod(x, x), prod(vec_data(x), vec_data(x))) | ||
| }) | ||
|
|
||
| test_that("broadcasts input using vctrs", { | ||
| x <- rray(c(5, 6), c(2, 2)) | ||
| expect_equal(prod(x, 5), prod(x, matrix(5, c(1, 2)))) | ||
| }) | ||
|
|
||
| test_that("always uses `na.rm = TRUE`", { | ||
| expect_equal(prod(rray(c(NA, 1L)), na.rm = FALSE), 1) | ||
| }) | ||
|
|
||
| # ------------------------------------------------------------------------------ | ||
| context("test-base-sum") | ||
|
|
||
| test_that("returns same values as base R", { | ||
| x <- rray(c(5, 6), c(2, 2)) | ||
| expect_equal(sum(x), sum(vec_data(x))) | ||
| expect_equal(sum(x, x), sum(vec_data(x), vec_data(x))) | ||
| }) | ||
|
|
||
| test_that("broadcasts input using vctrs", { | ||
| x <- rray(c(5, 6), c(2, 2)) | ||
| expect_equal(sum(x, 5), sum(x, matrix(5, c(1, 2)))) | ||
| }) | ||
|
|
||
| test_that("always uses `na.rm = TRUE`", { | ||
| expect_equal(sum(rray(c(NA, 1L)), na.rm = FALSE), 1) | ||
| }) |