confidence intervals and other model info changes

Author: topepo

R/gen_additive_mod_data.R

@@ -76,9 +76,26 @@ set_pred(
   value  = list(
     pre  = NULL,
     post = function(results, object) {
-      # TODO fix this; see the logistic regression code
-      res <-tibble::tibble(.pred_lower = results$fit - 2*results$se.fit,
-                           .pred_upper = results$fit + 2*results$se.fit)
+      hf_lvl <- (1 - object$spec$method$pred$conf_int$extras$level)/2
+      const <-
+        qt(hf_lvl, df = object$fit$df.residual, lower.tail = FALSE)
+      trans <- object$fit$family$linkinv
+      res <-
+        tibble(
+          .pred_lower = trans(results$fit - const * results$se.fit),
+          .pred_upper = trans(results$fit + const * results$se.fit)
+        )
+      # In case of inverse or other links
+      if (any(res$.pred_upper < res$.pred_lower)) {
+        nms <- names(res)
+        res <- res[, 2:1]
+        names(res) <- nms
+      }
+
+      if (object$spec$method$pred$conf_int$extras$std_error) {
+        res$.std_error <- results$se.fit
+      }
+      res
     },
     func = c(fun = "predict"),
     args = list(
@@ -145,22 +162,9 @@ set_pred(
   type   = "class",
   value  = list(
     pre  = NULL,
-    post = function(results, object) {
-
-      tbl <-tibble::as_tibble(results)
-
-      if (ncol(tbl) == 1) {
-        res <- prob_to_class_2(tbl, object) %>%
-          tibble::as_tibble() %>%
-          stats::setNames("values") %>%
-          dplyr::mutate(values = as.factor(values))
-      } else{
-        res <- tbl %>%
-          apply(., 1, function(x)
-            which(max(x) == x)[1]) - 1 %>% #modify in the future for something more elegant when gets the formula ok
-          tibble::as_tibble()
-      }
-
+    post = function(x, object) {
+      x <- ifelse(x >= 0.5, object$lvl[2], object$lvl[1])
+      unname(x)
     },
     func = c(fun = "predict"),
     args = list(
@@ -177,9 +181,11 @@ set_pred(
   mode   = "classification",
   type   = "prob",
   value  = list(
-    pre  = NULL,
-    post = function(results, object) {
-      res <- tibble::as_tibble(results)
+    pre = NULL,
+    post = function(x, object) {
+      x <- tibble(v1 = 1 - x, v2 = x)
+      colnames(x) <- object$lvl
+      x
     },
     func = c(fun = "predict"),
     args = list(
@@ -207,3 +213,45 @@ set_pred(
 )
 
 
+set_pred(
+  model = "gen_additive_mod",
+  eng = "mgcv",
+  mode = "classification",
+  type = "conf_int",
+  value = list(
+    pre = NULL,
+    post = function(results, object) {
+      hf_lvl <- (1 - object$spec$method$pred$conf_int$extras$level)/2
+      const <-
+        qt(hf_lvl, df = object$fit$df.residual, lower.tail = FALSE)
+      trans <- object$fit$family$linkinv
+      res_2 <-
+        tibble(
+          lo = trans(results$fit - const * results$se.fit),
+          hi = trans(results$fit + const * results$se.fit)
+        )
+      res_1 <- res_2
+      res_1$lo <- 1 - res_2$hi
+      res_1$hi <- 1 - res_2$lo
+      lo_nms <- paste0(".pred_lower_", object$lvl)
+      hi_nms <- paste0(".pred_upper_", object$lvl)
+      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
+      }
+      res
+    },
+    func = c(fun = "predict"),
+    args =
+      list(
+        object = rlang::expr(object$fit),
+        newdata = rlang::expr(new_data),
+        type = "link",
+        se.fit = TRUE
+      )
+  )
+)
+