Moved exception code out of train.default to model code for issue #710

topepo · Aug 18, 2017 · ecfc0fa · ecfc0fa
1 parent 9bfa386
commit ecfc0fa
Show file tree

Hide file tree

Showing 3 changed files with 40 additions and 29 deletions.
diff --git a/models/files/pam.R b/models/files/pam.R
@@ -11,11 +11,15 @@ modelInfo <- list(label = "Nearest Shrunken Centroids",
                     initialThresh <- pamr::pamr.train(list(x=t(x), y=y))$threshold
                     initialThresh <- initialThresh[-c(1, length(initialThresh))]
                     if(search == "grid") {
-                      out <- data.frame(threshold = seq(from = min(initialThresh),
-                                                        to = max(initialThresh), 
-                                                        length = len))
+                      out <- data.frame(threshold = 
+                                          seq(from = min(initialThresh),
+                                              to = max(initialThresh), 
+                                              length = len))
                     } else {
-                      out <- data.frame(threshold = runif(len, min = min(initialThresh),max = max(initialThresh)))
+                      out <- data.frame(threshold = 
+                                          runif(len, 
+                                                min = min(initialThresh),
+                                                max = max(initialThresh)))
                     }
                     out
 
@@ -26,18 +30,23 @@ modelInfo <- list(label = "Nearest Shrunken Centroids",
                     submodels <- list(grid[-1,,drop = FALSE])       
                     list(loop = loop, submodels = submodels)
                   },
-                  fit = function(x, y, wts, param, lev, last, classProbs, ...)
-                    pamr::pamr.train(list(x = t(x), y = y), threshold = param$threshold, ...),
+                  fit = function(x, y, wts, param, lev, last, classProbs, ...) {
+                    res <- pamr::pamr.train(list(x = t(x), y = y), 
+                                            threshold = param$threshold, ...)
+                    if (last) {
+                      res$xData <- x
+                      res$yData <- y
+                    }
+                    res
+                  }, 
                   predict = function(modelFit, newdata, submodels = NULL) {
                     out <- pamr::pamr.predict(modelFit,
                                               t(newdata),
                                               threshold = modelFit$tuneValue$threshold)
-                    if(!is.null(submodels))
-                    {
+                    if(!is.null(submodels)) {
                       tmp <- vector(mode = "list", length = nrow(submodels) + 1)
                       tmp[[1]] <- out
-                      for(j in seq(along = submodels$threshold))
-                      {
+                      for(j in seq(along = submodels$threshold)) {
                         tmp[[j+1]] <- pamr::pamr.predict(modelFit,
                                                          t(newdata),
                                                          threshold = submodels$threshold[j])
@@ -50,13 +59,11 @@ modelInfo <- list(label = "Nearest Shrunken Centroids",
                     out <- pamr::pamr.predict(modelFit, t(newdata),
                                               threshold = modelFit$tuneValue$threshold,
                                               type= "posterior")
-                    if(!is.null(submodels))
-                    {
+                    if(!is.null(submodels)) {
                       tmp <- vector(mode = "list", length = nrow(submodels) + 1)
                       tmp[[1]] <- out
 
-                      for(j in seq(along = submodels$threshold))
-                      {
+                      for(j in seq(along = submodels$threshold)) {
                         tmpProb <-  pamr::pamr.predict(modelFit, t(newdata),
                                                        threshold =  submodels$threshold[j],
                                                        type= "posterior")
@@ -67,20 +74,30 @@ modelInfo <- list(label = "Nearest Shrunken Centroids",
                     out
                   },
                   predictors = function(x, newdata = NULL, threshold = NULL,  ...) {
-                    if(is.null(newdata))
-                    {
-                      if(!is.null(x$xData)) newdata <- x$xData else stop("must supply newdata") 
+                    if (is.null(newdata)) {
+                      if (!is.null(x$xData))
+                        newdata <- x$xData
+                      else
+                        stop("must supply newdata")
                     }
-                    if(is.null(threshold))
-                    {
-                      if(!is.null(x$threshold)) threshold <- x$threshold else stop("must supply threshold") 
+                    if (is.null(threshold)) {
+                      if (!is.null(x$threshold))
+                        threshold <-
+                          x$threshold
+                      else
+                        stop("must supply threshold")
                     }
-                    varIndex <- pamr::pamr.predict(x, newx = newdata, threshold = threshold, type = "nonzero")
+                    varIndex <- pamr::pamr.predict(x, 
+                                                   newx = newdata, 
+                                                   threshold = threshold, 
+                                                   type = "nonzero")
                     colnames(newdata)[varIndex]
                   },
                   varImp = function (object, threshold = NULL, data = NULL, ...) {
-                    if(is.null(data)) data <- object$xData
-                    if(is.null(threshold)) threshold <- object$tuneValue$threshold
+                    if(is.null(data)) 
+                      data <- object$xData
+                    if(is.null(threshold)) 
+                      threshold <- object$tuneValue$threshold
                     if( dim(object$centroids)[1] != dim(data)[2]) 
                       stop("the number of columns (=variables) is not consistent with the pamr object")
 

diff --git a/pkg/caret/R/train.default.R b/pkg/caret/R/train.default.R
@@ -861,12 +861,6 @@ train.default <- function(x, y,
     }
   } else outData <- NULL
 
-  ## In the case of pam, the data will need to be saved differently
-  if(trControl$returnData & method == "pam") {
-    finalModel$xData <- x
-    finalModel$yData <- y
-  }
-
   if(trControl$savePredictions == "final")
     tmp$predictions <- merge(bestTune, tmp$predictions)
 

diff --git a/pkg/caret/inst/models/models.RData b/pkg/caret/inst/models/models.RData