add tidy() methods (closes #58)

Author: simonpcouch

NAMESPACE

@@ -29,6 +29,7 @@ S3method(required_pkgs,numeric_range)
 S3method(required_pkgs,predictions_custom)
 S3method(required_pkgs,probability_calibration)
 S3method(required_pkgs,probability_threshold)
+S3method(tidy,tailor)
 S3method(tunable,equivocal_zone)
 S3method(tunable,numeric_calibration)
 S3method(tunable,numeric_range)

R/adjust-equivocal-zone.R

@@ -142,6 +142,3 @@ tunable.equivocal_zone <- function(x, ...) {
     component_id = "equivocal_zone"
   )
 }
-
-# todo missing methods:
-# todo tidy

R/adjust-numeric-calibration.R

@@ -130,6 +130,3 @@ required_pkgs.numeric_calibration <- function(x, ...) {
 tunable.numeric_calibration <- function(x, ...) {
   no_param
 }
-
-# todo missing methods:
-# todo tidy

R/adjust-numeric-range.R

@@ -146,6 +146,3 @@ tunable.numeric_range <- function(x, ...) {
     component_id = "numeric_range"
   )
 }
-
-# todo missing methods:
-# todo tidy

R/adjust-predictions-custom.R

@@ -90,6 +90,3 @@ required_pkgs.predictions_custom <- function(x, ...) {
 tunable.predictions_custom <- function(x, ...) {
   no_param
 }
-
-# todo missing methods:
-# todo tidy

R/adjust-probability-calibration.R

@@ -138,6 +138,3 @@ required_pkgs.probability_calibration <- function(x, ...) {
 tunable.probability_calibration <- function(x, ...) {
   no_param
 }
-
-# todo missing methods:
-# todo tidy

R/adjust-probability-threshold.R

@@ -121,6 +121,3 @@ tunable.probability_threshold <- function(x, ...) {
     component_id = "probability_threshold"
   )
 }
-
-# todo missing methods:
-# todo tidy

R/tailor.R

@@ -269,5 +269,3 @@ tunable.tailor <- function(x, ...) {
   }
   res
 }
-
-# todo tidy (this should probably just be `adjustment_orderings()`)

R/tidy.R

@@ -0,0 +1,53 @@
+
+#' Tidy a tailor object
+#'
+#' @description
+#' Describe a tailor's adjustments in a tibble with one row per adjustment.
+#'
+#' @param x A [tailor()] object.
+#' @param number Optional. A single integer between 1 and the number of
+#' adjustments.
+#' @param ... Currently unused; must be empty.
+#'
+#' @returns
+#' A tibble containing information about the tailor's adjustments including
+#' their ordering, whether they've been trained, and whether they require
+#' training with a separate calibration set.
+#'
+#' @export
+tidy.tailor <- function(x, number = NA, ...) {
+  n_adjustments <- length(x$adjustments)
+  check_number_whole(
+    number, min = 1, max = as.double(n_adjustments), allow_na = TRUE
+  )
+  check_dots_empty()
+  if (is.na(number)) {
+    number <- seq_len(n_adjustments)
+  }
+
+  res <- adjustment_orderings(x$adjustments[number])
+
+  res <- vctrs::vec_cbind(
+    number = number,
+    res,
+    trained = purrr::map_lgl(x$adjustments[number], purrr::pluck, "trained"),
+    requires_training = purrr::map_lgl(
+      x$adjustments[number], purrr::pluck, "requires_fit"
+    )
+  )
+
+  tibble::new_tibble(res)
+}
+
+tidy_adjustments <- function(adjustments) {
+  res <- adjustment_orderings(x$adjustments)
+
+  res <- vctrs::vec_cbind(
+    number = seq_len(nrow(res)),
+    res,
+    trained = purrr::map_lgl(x$adjustments, purrr::pluck, "trained"),
+    requires_train = purrr::map_lgl(x$adjustments, purrr::pluck, "requires_fit")
+  )
+
+  tibble::new_tibble(res)
+}

man/tidy.tailor.Rd

@@ -0,0 +1,8 @@
+# tidy.tailor errors informatively with bad arguments
+
+    Code
+      tidy(tlr, number = 4)
+    Condition
+      Error in `tidy()`:
+      ! `number` must be a whole number between 1 and 2 or `NA`, not the number 4.
+

tests/testthat/_snaps/tidy.md

@@ -0,0 +1,65 @@
+test_that("tidy.tailor works", {
+  library(tibble)
+
+  set.seed(1)
+  d_calibration <- tibble(y = rnorm(100), y_pred = y/2 + rnorm(100))
+  d_test <- tibble(y = rnorm(100), y_pred = y/2 + rnorm(100))
+
+  # TODO: reintroduce custom predictions when #61 is resolved
+  tlr <-
+    tailor() %>%
+    adjust_numeric_calibration() %>%
+    adjust_numeric_range(lower_limit = 2) #%>%
+    #adjust_predictions_custom(squared = y_pred^2)
+
+  tidy_tlr <- tidy(tlr)
+
+  expect_s3_class(tidy_tlr, "tbl_df")
+  expect_equal(nrow(tidy_tlr), length(tlr$adjustments))
+  expect_named(
+    tidy_tlr,
+    c("number", "name", "input", "output_numeric", "output_prob",
+      "output_class", "output_all", "trained", "requires_training")
+  )
+  expect_equal(tidy_tlr$number, seq_len(length(tlr$adjustments)))
+  expect_false(any(tidy_tlr$trained))
+  expect_true(any(tidy_tlr$requires_training))
+
+  tidy_tlr_1 <- tidy(tlr, 1)
+  tidy_tlr_2 <- tidy(tlr, 2)
+
+  expect_equal(tidy_tlr[1,], tidy_tlr_1)
+  expect_equal(tidy_tlr[2,], tidy_tlr_2)
+
+  tlr_fit <- fit(tlr, d_calibration, outcome = y, estimate = y_pred)
+
+  tidy_tlr_fit <- tidy(tlr_fit)
+
+  expect_identical(
+    tidy_tlr[names(tidy_tlr) != "trained"],
+    tidy_tlr_fit[names(tidy_tlr_fit) != "trained"]
+  )
+  expect_true(all(tidy_tlr_fit$trained))
+})
+
+test_that("tidy.tailor errors informatively with bad arguments", {
+  tlr <-
+    tailor() %>%
+    adjust_numeric_calibration() %>%
+    adjust_numeric_range(lower_limit = 2)
+
+  expect_error(tidy(tlr, silly = "head"), class = "rlib_error_dots_nonempty")
+  expect_snapshot(error = TRUE, tidy(tlr, number = 4))
+})
+
+test_that("tidying a tailor with no adjustments", {
+  tidy_tlr <- tidy(tailor())
+
+  expect_equal(nrow(tidy_tlr), 0)
+  expect_equal(
+    ncol(tidy_tlr),
+    tailor() %>%
+      adjust_numeric_calibration() %>%
+      tidy() %>%
+      ncol())
+})