framework for multivariate y predictions

Author: topepo

R/aaa.R

@@ -2,7 +2,11 @@
 maybe_multivariate <- function(results, object) {
 
   if (isTRUE(ncol(results) > 1)) {
+    nms <- colnames(results)
     results <- as_tibble(results, .name_repair = "minimal")
+    if (length(nms) == 0 && length(object$preproc$y_var) == ncol(results)) {
+      names(results) <- object$preproc$y_var
+    }
   }  else {
     results <- unname(results[, 1])
   }

R/fit_helpers.R

@@ -59,7 +59,7 @@ form_form <-
       env = env,
       ...
     )
-    res$preproc <- NA
+    res$preproc <- list(y_var = all.vars(env$formula[[2]]))
     res
   }
 
@@ -114,7 +114,12 @@ xy_xy <- function(object, env, control, target = "none", ...) {
     env = env,
     ...
   )
-  res$preproc <- NA
+  if (is.vector(env$y)) {
+    y_name <- character(0)
+  } else {
+    y_name <- colnames(env$y)
+  }
+  res$preproc <- list(y_var = y_name)
   res
 }
 
@@ -144,6 +149,7 @@ form_xy <- function(object, control, env,
     control = control,
     target = target
   )
+  data_obj$y_var <- all.vars(env$formula[[2]])
   data_obj$x <- NULL
   data_obj$y <- NULL
   data_obj$weights <- NULL
@@ -177,7 +183,12 @@ xy_form <- function(object, env, control, ...) {
     control = control,
     ...
   )
-  res$preproc <- data_obj["x_var"]
+  if (is.vector(env$y)) {
+    data_obj$y_var <- character(0)
+  } else {
+    data_obj$y_var <- colnames(env$y)
+  }
+  res$preproc <- data_obj[c("x_var", "y_var")]
   res
 }
 

R/misc.R

@@ -223,3 +223,15 @@ check_outcome <- function(y, spec) {
   invisible(NULL)
 }
 
+
+# Get's a character string of varible names used as the outcome
+# in a terms object
+terms_y <- function(x) {
+  att <- attributes(x)
+  resp_ind <- att$response
+  y_expr <- att$predvars[[resp_ind + 1]]
+  all.vars(y_expr)
+}
+
+
+

R/mlp.R

@@ -374,15 +374,6 @@ keras_mlp <-
     model
   }
 
-keras_numeric_post <- function(results, object) {
-  if (ncol(results) > 1 && !is.null(object$fit$y_names)) {
-    print(object$fit$y_names)
-    colnames(results) <- object$fit$y_names
-  }
-  maybe_multivariate(results, object)
-}
-
-
 
 nnet_softmax <- function(results, object) {
   if (ncol(results) == 1)

R/mlp_data.R

@@ -84,7 +84,7 @@ set_pred(
   type = "numeric",
   value = list(
     pre = NULL,
-    post = keras_numeric_post,
+    post = maybe_multivariate,
     func = c(fun = "predict"),
     args =
       list(

R/predict.R

@@ -216,10 +216,12 @@ make_pred_call <- function(x) {
   cl
 }
 
+
 prepare_data <- function(object, new_data) {
   fit_interface <- object$spec$method$fit$interface
 
-  if (!all(is.na(object$preproc))) {
+  pp_names <- names(object$preproc)
+  if (any(pp_names == "terms") | any(pp_names == "x_var")) {
     # Translation code
     if (fit_interface == "formula") {
       new_data <- convert_xy_to_form_new(object$preproc, new_data)

tests/testthat/test_misc.R

@@ -29,3 +29,30 @@ test_that('other objects', {
 
 # ------------------------------------------------------------------------------
 
+context("getting y names from terms")
+
+test_that('getting y names from terms', {
+
+  expect_equal(
+    parsnip:::terms_y(lm(cbind(mpg, disp)  ~., data = mtcars)$terms),
+    c("mpg", "disp")
+  )
+
+  expect_equal(
+    parsnip:::terms_y(lm(mpg  ~., data = mtcars)$terms),
+    "mpg"
+  )
+
+  expect_equal(
+    parsnip:::terms_y(lm(log(mpg)  ~., data = mtcars)$terms),
+    "mpg"
+  )
+
+  expect_equal(
+    parsnip:::terms_y(terms(  ~., data = mtcars)),
+    character(0)
+  )
+
+
+})
+