implement tune_args() and tunable() (#51)

* implement `tune_args()` and `tunable()`

* remove redundant method

* namespace fn in test

* more machinery from recipes

* add vctrs to Imports

* test `find_tune_id()`

* add snapshot

* address `vec_rbind()` internal error re: bad recycling

* update for new object structure

* add `extract_parameter_set_dials()` method

* migrate check helper from workflows

* generate snaps

Author: simonpcouch

DESCRIPTION

@@ -27,12 +27,15 @@ Imports:
     purrr,
     rlang (>= 1.1.0),
     tibble,
-    tidyselect
+    tidyselect,
+    vctrs
 Suggests: 
+    dials,
     modeldata,
     testthat (>= 3.0.0),
     workflows
 Remotes:
+    tidymodels/dials#358,
     tidymodels/probably,
     tidymodels/workflows
 Config/testthat/edition: 3

NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(extract_parameter_dials,tailor)
+S3method(extract_parameter_set_dials,tailor)
 S3method(fit,equivocal_zone)
 S3method(fit,numeric_calibration)
 S3method(fit,numeric_range)
@@ -33,6 +35,9 @@ S3method(tunable,numeric_range)
 S3method(tunable,predictions_custom)
 S3method(tunable,probability_calibration)
 S3method(tunable,probability_threshold)
+S3method(tunable,tailor)
+S3method(tune_args,adjustment)
+S3method(tune_args,tailor)
 export("%>%")
 export(adjust_equivocal_zone)
 export(adjust_numeric_calibration)

R/adjust-equivocal-zone.R

@@ -128,16 +128,15 @@ required_pkgs.equivocal_zone <- function(x, ...) {
 
 #' @export
 tunable.equivocal_zone <- function(x, ...) {
-  tibble::new_tibble(list(
+  tibble::tibble(
     name = "buffer",
     call_info = list(list(pkg = "dials", fun = "buffer")),
     source = "tailor",
     component = "equivocal_zone",
     component_id = "equivocal_zone"
-  ))
+  )
 }
 
 # todo missing methods:
-# todo tune_args
 # todo tidy
 # todo extract_parameter_set_dials

R/adjust-numeric-calibration.R

@@ -126,6 +126,5 @@ tunable.numeric_calibration <- function(x, ...) {
 }
 
 # todo missing methods:
-# todo tune_args
 # todo tidy
 # todo extract_parameter_set_dials

R/adjust-numeric-range.R

@@ -129,7 +129,7 @@ required_pkgs.numeric_range <- function(x, ...) {
 
 #' @export
 tunable.numeric_range <- function(x, ...) {
-  tibble::new_tibble(list(
+  tibble::tibble(
     name = c("lower_limit", "upper_limit"),
     call_info = list(
       list(pkg = "dials", fun = "lower_limit"), # todo make these dials functions
@@ -138,10 +138,9 @@ tunable.numeric_range <- function(x, ...) {
     source = "tailor",
     component = "numeric_range",
     component_id = "numeric_range"
-  ))
+  )
 }
 
 # todo missing methods:
-# todo tune_args
 # todo tidy
 # todo extract_parameter_set_dials

R/adjust-predictions-custom.R

@@ -92,6 +92,5 @@ tunable.predictions_custom <- function(x, ...) {
 }
 
 # todo missing methods:
-# todo tune_args
 # todo tidy
 # todo extract_parameter_set_dials

R/adjust-probability-calibration.R

@@ -134,6 +134,5 @@ tunable.probability_calibration <- function(x, ...) {
 }
 
 # todo missing methods:
-# todo tune_args
 # todo tidy
 # todo extract_parameter_set_dials

R/adjust-probability-threshold.R

@@ -113,16 +113,15 @@ required_pkgs.probability_threshold <- function(x, ...) {
 
 #' @export
 tunable.probability_threshold <- function(x, ...) {
-  tibble::new_tibble(list(
+  tibble::tibble(
     name = "threshold",
     call_info = list(list(pkg = "dials", fun = "threshold")),
     source = "tailor",
     component = "probability_threshold",
     component_id = "probability_threshold"
-  ))
+  )
 }
 
 # todo missing methods:
-# todo tune_args
 # todo tidy
 # todo extract_parameter_set_dials

R/extract.R

@@ -0,0 +1,47 @@
+#' @export
+extract_parameter_set_dials.tailor <- function(x, ...) {
+  all_args <- generics::tunable(x)
+  tuning_param <- generics::tune_args(x)
+  res <-
+    dplyr::inner_join(
+      tuning_param %>% dplyr::select(-tunable),
+      all_args,
+      by = c("name", "source", "component", "component_id")
+    ) %>%
+    dplyr::mutate(object = purrr::map(call_info, eval_call_info))
+
+  dials::parameters_constr(
+    res$name,
+    res$id,
+    res$source,
+    res$component,
+    res$component_id,
+    res$object
+  )
+}
+
+eval_call_info <- function(x) {
+  if (!is.null(x)) {
+    # Look for other options
+    allowed_opts <- c("range", "trans", "values")
+    if (any(names(x) %in% allowed_opts)) {
+      opts <- x[names(x) %in% allowed_opts]
+    } else {
+      opts <- list()
+    }
+    res <- try(rlang::eval_tidy(rlang::call2(x$fun, .ns = x$pkg, !!!opts)), silent = TRUE)
+    if (inherits(res, "try-error")) {
+      cli::cli_abort(
+        "Error when calling {.fn {x$fun}}: {as.character(res)}"
+      )
+    }
+  } else {
+    res <- NA
+  }
+  res
+}
+
+#' @export
+extract_parameter_dials.tailor <- function(x, parameter, ...) {
+  extract_parameter_dials(extract_parameter_set_dials(x), parameter)
+}

R/tailor.R

@@ -235,6 +235,42 @@ set_tailor_type <- function(object, y, call = caller_env()) {
 # todo: where to validate #levels?
 # todo setup eval_time
 # todo missing methods:
-# todo tune_args
+
+#' @export
+tune_args.tailor <- function(object, full = FALSE, ...) {
+  adjustments <- object$adjustments
+
+  if (length(adjustments) == 0L) {
+    return(tune_tbl())
+  }
+
+  res <- purrr::map(object$adjustments, tune_args, full = full)
+  res <- purrr::list_rbind(res)
+
+  tune_tbl(
+    res$name,
+    res$tunable,
+    res$id,
+    res$source,
+    res$component,
+    res$component_id,
+    full = full
+  )
+}
+
+#' @export
+tunable.tailor <- function(x, ...) {
+  if (length(x$adjustments) == 0) {
+    res <- no_param
+  } else {
+    res <- purrr::map(x$adjustments, tunable)
+    res <- vctrs::vec_rbind(!!!res)
+    if (nrow(res) > 0) {
+      res <- res[!is.na(res$name), ]
+    }
+  }
+  res
+}
+
 # todo tidy (this should probably just be `adjustment_orderings()`)
 # todo extract_parameter_set_dials