-
Notifications
You must be signed in to change notification settings - Fork 2
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
2ffdf11
commit 7150bff
Showing
3 changed files
with
261 additions
and
54 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
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,89 +1,179 @@ | ||
#' @import vctrs | ||
#' @importFrom utils globalVariables | ||
#' @importFrom rlang abort | ||
|
||
# ------------------------------------------------------------------------------ | ||
# Creation | ||
|
||
new_measure <- function(x, labels, ..., subclass = NULL) { | ||
new_vctr( | ||
.data = x, | ||
new_measure <- function(x = numeric(), location = numeric(), ..., subclass = NULL) { | ||
if (!is.numeric(x)) { | ||
abort("`x` must be a numeric vector.") | ||
} | ||
if (!is.numeric(location)) { | ||
abort("`location` must be a numeric vector.") | ||
} | ||
if (length(x) != length(location)) { | ||
abort("The lengths of `x` and `location` must be the same.") | ||
} | ||
|
||
new_rcrd( | ||
fields = purrr::compact( | ||
list( | ||
x = x, | ||
location = location | ||
) | ||
), | ||
..., | ||
class = c(subclass, "measure") | ||
) | ||
|
||
} | ||
|
||
measure <- function(x = numeric(), location = numeric()) { | ||
new_measure(x, location) | ||
} | ||
|
||
is_measure <- function(x) { | ||
inherits(x, "measure") | ||
} | ||
|
||
measure <- function() { | ||
which <- vec_cast(which, integer()) | ||
# ------------------------------------------------------------------------------ | ||
# Printing | ||
|
||
# no duplicates allowed | ||
which <- unique(which) | ||
#'@export | ||
format.measure <- function(x) { | ||
format(field(x, "x"), trim = TRUE, digits = 2) | ||
# format(field(x, "location"), trim = TRUE) | ||
} | ||
|
||
# which cannot go outside the range of the number of values in x | ||
if (length(which) > 0L && max(which) > length(x)) { | ||
msg <- paste0("The largest value of `which` can be ", length(x), ".") | ||
abort(msg) | ||
} | ||
#' @export | ||
vec_ptype_abbr.measure <- function(x, ...) { | ||
"meas" | ||
} | ||
|
||
labs <- levels(x) | ||
# ------------------------------------------------------------------------------ | ||
# Coercion | ||
|
||
# Check for `equivocal` in labels. Not allowed. | ||
if (equivocal %in% labs) { | ||
msg <- paste0( | ||
"`\"", equivocal, "\"`", | ||
"is reserved for equivocal values", | ||
"and must not already be a level." | ||
) | ||
abort(msg) | ||
#' @export | ||
as_measure <- function(x) { | ||
UseMethod("as_measure") | ||
} | ||
|
||
#' @export | ||
as_measure.default <- function(x) { | ||
abort_default(x, "as_measure") | ||
} | ||
|
||
#' @export | ||
as_measure.data.frame <- function(x) { | ||
if (ncol(x) != 2) { | ||
abort("A data frame must have exactly 2 columns to be converted to a measure.") | ||
} | ||
|
||
# rip out the underlying integer structure | ||
# as.integer() also removes attributes | ||
x_int <- as.integer(unclass(x)) | ||
new_measure(x[[1]], x[[2]]) | ||
} | ||
|
||
# declare equivocal | ||
x_int[which] <- 0L | ||
#' @export | ||
as_measure.matrix <- function(x) { | ||
if (ncol(x) != 2) { | ||
abort("A matrix must have exactly 2 columns to be converted to a measure.") | ||
} | ||
|
||
new_class_pred( | ||
x = x_int, | ||
labels = labs, | ||
ordered = is.ordered(x), | ||
equivocal = equivocal | ||
) | ||
new_measure(x[, 1], x[, 2]) | ||
} | ||
|
||
# ------------------------------------------------------------------------------ | ||
# Printing | ||
# Casting | ||
|
||
#' @export | ||
vec_cast.measure.measure <- function(x, to, ...) x | ||
|
||
# Always return a character vector | ||
# Rely on as.character.factor() for NA handling | ||
# Used by data.frame() columns and general printing | ||
#' @export | ||
format.measure <- function(x, ...) { | ||
vec_cast.measure.data.frame <- function(x, to, ...) as_measure(x) | ||
|
||
#' @export | ||
vec_cast.measure.matrix <- function(x, to, ...) as_measure(x) | ||
|
||
#' @export | ||
vec_cast.data.frame.measure <- function(x, to, ...) { | ||
data.frame(x = field(x, "x"), location = field(x, "location")) | ||
} | ||
|
||
# ------------------------------------------------------------------------- | ||
# Check that measures are the `measure_obj` class | ||
#' @export | ||
vec_cast.matrix.measure <- function(x, to, ...) { | ||
matrix(c(field(x, "x"), field(x, "location")), ncol = 2) | ||
} | ||
|
||
is_measure <- function(x) { | ||
inherits(x, "measure_obj") | ||
# ------------------------------------------------------------------------------ | ||
# Equality and comparison | ||
|
||
#' @export | ||
vec_proxy_equal.measure <- function(x, ...) { | ||
data.frame(x = field(x, "x"), location = field(x, "location")) | ||
} | ||
|
||
# ------------------------------------------------------------------------------ | ||
# Coercion | ||
# Arithmetic | ||
|
||
#' Coerce to a `measure` object | ||
#' | ||
#' `as_measure()` provides coercion to `measure` from other | ||
#' existing objects. | ||
#' | ||
#' @examples | ||
#' | ||
#' | ||
#' @export | ||
as_measure <- function(x) { | ||
UseMethod("as_measure") | ||
vec_arith.measure <- function(op, x, y, ...) { | ||
UseMethod("vec_arith.measure", y) | ||
} | ||
|
||
#' @export | ||
as_measure.default <- function(x) { | ||
abort_default(x, "as_class_pred") | ||
vec_arith.measure.default <- function(op, x, y, ...) { | ||
stop_incompatible_op(op, x, y) | ||
} | ||
|
||
#' @export | ||
vec_arith.measure.numeric <- function(op, x, y, ...) { | ||
switch( | ||
op, | ||
"+" = , | ||
"-" = new_measure(vec_arith_base(op, x$x, y), x$location), | ||
"/" = , | ||
"*" = new_measure(vec_arith_base(op, x$x, y), x$location), | ||
stop_incompatible_op(op, x, y) | ||
) | ||
} | ||
|
||
#' @export | ||
vec_arith.numeric.measure <- function(op, x, y, ...) { | ||
switch( | ||
op, | ||
"+" = , | ||
"-" = , | ||
"/" = new_measure(vec_arith_base(op, x, y$x), y$location), | ||
"*" = new_measure(vec_arith_base(op, x, y$x), y$location), | ||
stop_incompatible_op(op, x, y) | ||
) | ||
} | ||
|
||
#' @export | ||
vec_arith.measure.measure <- function(op, x, y, ...) { | ||
switch( | ||
op, | ||
"+" = , | ||
"-" = new_measure(vec_arith_base(op, x$x, y$x), x$location), | ||
"/" = vec_arith_base(op, x$x, y$x), | ||
"*" = stop_incompatible_op(op, x, y), | ||
stop_incompatible_op(op, x, y) | ||
) | ||
} | ||
|
||
#' @export | ||
vec_arith.measure.MISSING <- function(op, x, y, ...) { | ||
switch(op, | ||
`-` = new_measure(-x$x, x$location), | ||
`+` = x, | ||
stop_incompatible_op(op, x, y) | ||
) | ||
} | ||
|
||
# ------------------------------------------------------------------------------ | ||
# Extract underlying data | ||
|
||
#' @export | ||
vec_data.measure <- function(x) { | ||
data.frame(x = field(x, "x"), location = field(x, "location"), stringsAsFactors = FALSE) | ||
} |
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,96 @@ | ||
library(testthat) | ||
|
||
# Creation | ||
test_that("measure objects can be created", { | ||
x <- c(1, 2, 3) | ||
location <- c(0.1, 0.2, 0.3) | ||
m <- measure(x, location) | ||
expect_s3_class(m, "measure") | ||
expect_equal(field(m, "x"), x) | ||
expect_equal(field(m, "location"), location) | ||
}) | ||
|
||
test_that("measure constructor checks for valid input", { | ||
expect_error(measure("a", 1), "must be a numeric vector") | ||
expect_error(measure(1, "a"), "must be a numeric vector") | ||
expect_error(measure(1:3, 1:2), "must be the same") | ||
}) | ||
|
||
# Printing | ||
test_that("measure objects are printed correctly", { | ||
m <- measure(1:3, c(0.1, 0.2, 0.3)) | ||
expect_output(print(m), "Measure \\[3 × 3\\]") | ||
expect_equal(vec_ptype_abbr(m), "msre") | ||
expect_equal(vec_ptype_full(m), "measure<double>") | ||
}) | ||
|
||
# Coercion | ||
test_that("objects can be coerced to measure", { | ||
df <- data.frame(x = 1:3, location = c(0.1, 0.2, 0.3)) | ||
m_df <- as_measure(df) | ||
expect_s3_class(m_df, "measure") | ||
|
||
mat <- matrix(c(1:3, 0.1, 0.2, 0.3), ncol = 2) | ||
m_mat <- as_measure(mat) | ||
expect_s3_class(m_mat, "measure") | ||
|
||
expect_error(as_measure(data.frame(1:3)), "must have exactly 2 columns") | ||
expect_error(as_measure(matrix(1:9, ncol = 3)), "must have exactly 2 columns") | ||
}) | ||
|
||
# Casting | ||
test_that("measure objects can be cast to other types", { | ||
m <- measure(1:3, c(0.1, 0.2, 0.3)) | ||
|
||
m_df <- vec_cast(m, data.frame()) | ||
expect_equal(m_df, data.frame(x = 1:3, location = c(0.1, 0.2, 0.3))) | ||
|
||
m_mat <- vec_cast(m, matrix()) | ||
expect_equal(m_mat, matrix(c(1:3, 0.1, 0.2, 0.3), ncol = 2)) | ||
|
||
df <- data.frame(x = 1:3, location = c(0.1, 0.2, 0.3)) | ||
m_from_df <- vec_cast(df, new_measure()) | ||
expect_s3_class(m_from_df, "measure") | ||
|
||
mat <- matrix(c(1:3, 0.1, 0.2, 0.3), ncol = 2) | ||
m_from_mat <- vec_cast(mat, new_measure()) | ||
expect_s3_class(m_from_mat, "measure") | ||
}) | ||
|
||
# Equality and comparison | ||
test_that("measure objects can be compared for equality", { | ||
m1 <- measure(1:3, c(0.1, 0.2, 0.3)) | ||
m2 <- measure(1:3, c(0.1, 0.2, 0.3)) | ||
m3 <- measure(1:3, c(0.1, 0.2, 0.4)) | ||
|
||
expect_true(vec_equal(m1, m2)) | ||
expect_false(vec_equal(m1, m3)) | ||
}) | ||
|
||
# Arithmetic | ||
test_that("arithmetic operations work on measure objects", { | ||
m <- measure(1:3, c(0.1, 0.2, 0.3)) | ||
|
||
expect_equal(field(m + 1, "x"), 2:4) | ||
expect_equal(field(1 + m, "x"), 2:4) | ||
expect_equal(field(m - 1, "x"), 0:2) | ||
expect_equal(field(m * 2, "x"), 2:6) | ||
expect_equal(field(2 * m, "x"), 2:6) | ||
expect_equal(field(m / 2, "x"), c(0.5, 1, 1.5)) | ||
|
||
m2 <- measure(4:6, c(0.1, 0.2, 0.3)) | ||
expect_equal(field(m + m2, "x"), 5:9) | ||
expect_equal(field(m - m2, "x"), -3:1) | ||
expect_equal(m / m2, 1:3 / 4:6) | ||
|
||
expect_error(m * m2, "not permitted") | ||
|
||
expect_equal(field(-m, "x"), -(1:3)) | ||
expect_equal(field(+m, "x"), 1:3) | ||
}) | ||
|
||
# Extracting underlying data | ||
test_that("underlying data can be extracted from measure objects", { | ||
m <- measure(1:3, c(0.1, 0.2, 0.3)) | ||
expect_equal(vec_data(m), data.frame(x = 1:3, location = c(0.1, 0.2, 0.3))) | ||
}) |