From 7150bffca555a3db58106e28919411048cd72f38 Mon Sep 17 00:00:00 2001
From: James Wade <github@jameshwade.com>
Date: Sun, 10 Mar 2024 07:14:02 -0400
Subject: [PATCH] measure class wip

---
 NAMESPACE                           |  21 +++
 R/class-measure.R                   | 198 ++++++++++++++++++++--------
 tests/testthat/test-class-measure.R |  96 ++++++++++++++
 3 files changed, 261 insertions(+), 54 deletions(-)
 create mode 100644 tests/testthat/test-class-measure.R

diff --git a/NAMESPACE b/NAMESPACE
index 0b98d43..5278180 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,11 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as_measure,data.frame)
+S3method(as_measure,default)
+S3method(as_measure,matrix)
 S3method(bake,step_baseline)
 S3method(bake,step_measure_input_long)
 S3method(bake,step_measure_input_wide)
 S3method(bake,step_measure_output_long)
 S3method(bake,step_measure_output_wide)
 S3method(bake,step_measure_savitzky_golay)
+S3method(format,measure)
 S3method(prep,step_baseline)
 S3method(prep,step_measure_input_long)
 S3method(prep,step_measure_input_wide)
@@ -24,17 +28,34 @@ S3method(tidy,step_measure_input_wide)
 S3method(tidy,step_measure_output_long)
 S3method(tidy,step_measure_output_wide)
 S3method(tidy,step_measure_savitzky_golay)
+S3method(vec_arith,measure.MISSING)
+S3method(vec_arith,measure.default)
+S3method(vec_arith,measure.measure)
+S3method(vec_arith,measure.numeric)
+S3method(vec_arith,numeric.measure)
+S3method(vec_cast,data.frame.measure)
+S3method(vec_cast,matrix.measure)
+S3method(vec_cast,measure.data.frame)
+S3method(vec_cast,measure.matrix)
+S3method(vec_cast,measure.measure)
+S3method(vec_proxy_equal,measure)
+S3method(vec_ptype_abbr,measure)
+export(as_measure)
 export(step_measure_input_long)
 export(step_measure_input_wide)
 export(step_measure_output_long)
 export(step_measure_output_wide)
 export(step_measure_savitzky_golay)
 export(subtract_rf_baseline)
+export(vec_arith.measure)
+export(vec_data.measure)
 import(recipes)
 import(rlang)
+import(vctrs)
 importFrom(dplyr,arrange)
 importFrom(dplyr,mutate)
 importFrom(dplyr,select)
 importFrom(glue,glue)
+importFrom(rlang,abort)
 importFrom(tibble,tibble)
 importFrom(utils,globalVariables)
diff --git a/R/class-measure.R b/R/class-measure.R
index f347371..5560e8f 100644
--- a/R/class-measure.R
+++ b/R/class-measure.R
@@ -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)
 }
diff --git a/tests/testthat/test-class-measure.R b/tests/testthat/test-class-measure.R
new file mode 100644
index 0000000..6db2263
--- /dev/null
+++ b/tests/testthat/test-class-measure.R
@@ -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)))
+})