Tailor support (#103)

Author: EmilHvitfeldt

DESCRIPTION

@@ -37,12 +37,14 @@ Suggests:
     modeldata,
     parsnip,
     partykit,
+    probably,
     R6,
     recipes,
     rmarkdown,
     RSQLite,
     rstanarm,
     sparklyr,
+    tailor,
     testthat (>= 3.0.0),
     themis,
     tibble,

NAMESPACE

@@ -3,10 +3,14 @@
 S3method(augment,orbital_class)
 S3method(orbital,constparty)
 S3method(orbital,default)
+S3method(orbital,equivocal_zone)
 S3method(orbital,glm)
 S3method(orbital,last_fit)
 S3method(orbital,model_fit)
 S3method(orbital,model_spec)
+S3method(orbital,numeric_range)
+S3method(orbital,predictions_custom)
+S3method(orbital,probability_threshold)
 S3method(orbital,recipe)
 S3method(orbital,step_BoxCox)
 S3method(orbital,step_adasyn)
@@ -54,6 +58,7 @@ S3method(orbital,step_tomek)
 S3method(orbital,step_unknown)
 S3method(orbital,step_upsample)
 S3method(orbital,step_zv)
+S3method(orbital,tailor)
 S3method(orbital,workflow)
 S3method(orbital,xgb.Booster)
 S3method(predict,orbital_class)

NEWS.md

@@ -1,5 +1,11 @@
 # orbital (development version)
 
+* Added support for tailor package and its integration into workflows. The following adjustments have gained `orbital()` support. (#103)
+    - `adjust_equivocal_zone()`
+    - `adjust_numeric_range()`
+    - `adjust_predictions_custom()`
+    - `adjust_probability_threshold()`
+
 # orbital 0.3.1
 
 * Fixed bug where PCA steps didn't work if they were trained with more than 99 predictors. (#82)

R/adjust_equivocal_zone.R

@@ -0,0 +1,31 @@
+#' @export
+orbital.equivocal_zone <- function(x, tailor, type, prefix, ...) {
+  if (!rlang::is_missing(type) && !(all(c("prob", "class") %in% type))) {
+    cli::cli_abort(c(
+      x = "{.arg type} must contain {.val prob} and {.val class} to work with 
+      {.fn adjust_equivocal_zone}."
+    ))
+  }
+
+  input <- x$arguments
+
+  out_name <- tailor$columns$estimate
+  prob_name <- tailor$columns$probabilities[[1]]
+
+  levels <- gsub("^\\.pred_", "", tailor$columns$probabilities)
+
+  if (prefix != "prefix") {
+    out_name <- gsub("^\\.pred", prefix, out_name)
+    prob_name <- gsub("^\\.pred", prefix, prob_name)
+  }
+
+  out <- glue::glue(
+    "dplyr::case_when(
+    {prob_name} > {input$threshold} + {input$value} ~ '{levels[1]}',
+    {prob_name} < {input$threshold} - {input$value} ~ '{levels[2]}', 
+    .default = '[EQ]'
+    )"
+  )
+  names(out) <- out_name
+  out
+}

R/adjust_numeric_range.R

@@ -0,0 +1,25 @@
+#' @export
+orbital.numeric_range <- function(x, tailor, ...) {
+  lower <- x$arguments$lower_limit
+  upper <- x$arguments$upper_limit
+
+  estimate <- tailor$columns$estimate
+
+  if (!is.finite(lower) && !is.finite(upper)) {
+    return(NULL)
+  }
+
+  out <- "dplyr::case_when("
+
+  if (is.finite(lower)) {
+    out <- paste0(out, "{estimate} < {lower} ~ {lower},")
+  }
+  if (is.finite(upper)) {
+    out <- paste0(out, "{estimate} > {upper} ~ {upper},")
+  }
+
+  out <- paste0(out, "TRUE ~ {estimate})")
+  out <- glue::glue(out)
+  names(out) <- estimate
+  out
+}

R/adjust_predictions_custom.R

@@ -0,0 +1,11 @@
+#' @export
+orbital.predictions_custom <- function(x, ...) {
+  input <- x$arguments$commands
+
+  if (length(input) == 0) {
+    return(NULL)
+  }
+
+  out <- vapply(input, rlang::as_label, character(1))
+  out
+}

R/adjust_probability_threshold.R

@@ -0,0 +1,31 @@
+#' @export
+orbital.probability_threshold <- function(x, tailor, type, prefix, ...) {
+  if (!rlang::is_missing(type) && !(all(c("prob", "class") %in% type))) {
+    cli::cli_abort(c(
+      x = "{.arg type} must contain {.val prob} and {.val class} to work with 
+      {.fn adjust_equivocal_zone}."
+    ))
+  }
+
+  input <- x$arguments
+
+  prob_name <- tailor$columns$probabilities[[1]]
+
+  levels <- gsub("^\\.pred_", "", tailor$columns$probabilities)
+
+  out_name <- paste0(prefix, "_class")
+
+  if (prefix != "prefix") {
+    prob_name <- gsub("^\\.pred", prefix, prob_name)
+  }
+
+  out <- glue::glue(
+    "dplyr::case_when(
+    {prob_name} > {input$threshold} ~ '{levels[1]}',
+    {prob_name} < {input$threshold} ~ '{levels[2]}', 
+    .default = '[EQ]'
+    )"
+  )
+  names(out) <- out_name
+  out
+}

R/tailor.R

@@ -0,0 +1,11 @@
+#' @export
+orbital.tailor <- function(x, ...) {
+  out <- character()
+
+  for (adj in x$adjustments) {
+    new <- orbital(adj, tailor = x, ...)
+    out <- c(out, new)
+  }
+
+  new_orbital_class(out)
+}

R/workflows.R

@@ -4,12 +4,21 @@ orbital.workflow <- function(x, ..., prefix = ".pred", type = NULL) {
     cli::cli_abort("{.arg x} must be a fully trained {.cls workflow}.")
   }
 
-  if (length(x$post$actions) != 0) {
-    cli::cli_abort("post-processing is not yet supported in orbital.")
+  out <- character()
+  if ("tailor" %in% names(x$post$actions)) {
+    tailor_fit <- workflows::extract_tailor(x)
+    post <- orbital(tailor_fit, prefix = prefix, type = type)
+    out <- post
   }
 
   model_fit <- workflows::extract_fit_parsnip(x)
-  out <- orbital(model_fit, prefix = prefix, type = type)
+  mod <- orbital(model_fit, prefix = prefix, type = type)
+  mod_atr <- attributes(mod)
+  mod_atr$names <- c(mod_atr$names, names(out))
+  mod_cls <- class(mod)
+  out <- c(mod, out)
+  attributes(out) <- mod_atr
+  class(out) <- mod_cls
 
   preprocessor <- workflows::extract_preprocessor(x)
 

tests/testthat/_snaps/adjust_equivocal_zone.md

@@ -0,0 +1,24 @@
+# adjust_equivocal_zone errors if types aren't set
+
+    Code
+      orbital(wf_fit)
+    Condition
+      Error in `orbital()`:
+      x `type` must contain "prob" and "class" to work with `adjust_equivocal_zone()`.
+
+---
+
+    Code
+      orbital(wf_fit, type = "prob")
+    Condition
+      Error in `orbital()`:
+      x `type` must contain "prob" and "class" to work with `adjust_equivocal_zone()`.
+
+---
+
+    Code
+      orbital(wf_fit, type = "class")
+    Condition
+      Error in `orbital()`:
+      x `type` must contain "prob" and "class" to work with `adjust_equivocal_zone()`.
+