Merge pull request #390 from tidymodels/stan-function-switch

remove warnings with new stan version

Author: topepo

NAMESPACE

@@ -177,6 +177,7 @@ export(show_call)
 export(show_engines)
 export(show_fit)
 export(show_model_info)
+export(stan_conf_int)
 export(surv_reg)
 export(svm_poly)
 export(svm_rbf)

R/linear_reg_data.R

@@ -258,13 +258,11 @@ set_pred(
         res$.std_error <- apply(results, 2, sd, na.rm = TRUE)
       res
     },
-    func = c(pkg = "rstanarm", fun = "posterior_linpred"),
+    func = c(pkg = "parsnip", fun = "stan_conf_int"),
     args =
       list(
         object = expr(object$fit),
-        newdata = expr(new_data),
-        transform = TRUE,
-        seed = expr(sample.int(10^5, 1))
+        newdata = expr(new_data)
       )
   )
 )

R/logistic_reg_data.R

@@ -108,10 +108,11 @@ set_pred(
       res_1 <- res_2
       res_1$lo <- 1 - res_2$hi
       res_1$hi <- 1 - res_2$lo
-      res <- bind_cols(res_1, res_2)
       lo_nms <- paste0(".pred_lower_", object$lvl)
       hi_nms <- paste0(".pred_upper_", object$lvl)
-      colnames(res) <- c(lo_nms[1], hi_nms[1], lo_nms[2], hi_nms[2])
+      colnames(res_1) <- c(lo_nms[1], hi_nms[1])
+      colnames(res_2) <- c(lo_nms[2], hi_nms[2])
+      res <- bind_cols(res_1, res_2)
 
       if (object$spec$method$pred$conf_int$extras$std_error)
         res$.std_error <- results$se.fit
@@ -509,22 +510,22 @@ set_pred(
       res_1 <- res_2
       res_1$lo <- 1 - res_2$hi
       res_1$hi <- 1 - res_2$lo
-      res <- bind_cols(res_1, res_2)
       lo_nms <- paste0(".pred_lower_", object$lvl)
       hi_nms <- paste0(".pred_upper_", object$lvl)
-      colnames(res) <- c(lo_nms[1], hi_nms[1], lo_nms[2], hi_nms[2])
+      colnames(res_1) <- c(lo_nms[1], hi_nms[1])
+      colnames(res_2) <- c(lo_nms[2], hi_nms[2])
+      res <- bind_cols(res_1, res_2)
 
-      if (object$spec$method$pred$conf_int$extras$std_error)
+      if (object$spec$method$pred$conf_int$extras$std_error) {
         res$.std_error <- apply(results, 2, sd, na.rm = TRUE)
+      }
       res
     },
-    func = c(pkg = "rstanarm", fun = "posterior_linpred"),
+    func = c(pkg = "parsnip", fun = "stan_conf_int"),
     args =
       list(
-        object = quote(object$fit),
-        newdata = quote(new_data),
-        transform = TRUE,
-        seed = expr(sample.int(10^5, 1))
+        object = expr(object$fit),
+        newdata = expr(new_data)
       )
   )
 )
@@ -554,10 +555,11 @@ set_pred(
       res_1 <- res_2
       res_1$lo <- 1 - res_2$hi
       res_1$hi <- 1 - res_2$lo
-      res <- bind_cols(res_1, res_2)
       lo_nms <- paste0(".pred_lower_", object$lvl)
       hi_nms <- paste0(".pred_upper_", object$lvl)
-      colnames(res) <- c(lo_nms[1], hi_nms[1], lo_nms[2], hi_nms[2])
+      colnames(res_1) <- c(lo_nms[1], hi_nms[1])
+      colnames(res_2) <- c(lo_nms[2], hi_nms[2])
+      res <- bind_cols(res_1, res_2)
 
       if (object$spec$method$pred$pred_int$extras$std_error)
         res$.std_error <- apply(results, 2, sd, na.rm = TRUE)

R/misc.R

@@ -305,4 +305,28 @@ update_engine_parameters <- function(eng_args, ...) {
   ret
 }
 
+# ------------------------------------------------------------------------------
+# Since stan changed the function interface
+#' Wrapper for stan confidence intervals
+#' @param object A stan model fit
+#' @param newdata A data set.
+#' @export
+#' @keywords internal
+stan_conf_int <- function(object, newdata) {
+  check_installs(list(method = list(libs = "rstanarm")))
+  if (utils::packageVersion("rstanarm") >= "2.21.1") {
+    fn <- rlang::call2("posterior_epred", .ns = "rstanarm",
+                       object = expr(object),
+                       newdata = expr(newdata),
+                       seed = expr(sample.int(10^5, 1)))
+  } else {
+    fn <- rlang::call2("posterior_linpred", .ns = "rstanarm",
+                       object = expr(object),
+                       newdata = expr(newdata),
+                       transform = TRUE,
+                       seed = expr(sample.int(10^5, 1)))
+  }
+  rlang::eval_tidy(fn)
+}
+