From the rqPen package, quantile regression models rqnc and rqlasso w…

…ere added.

RegressionTests/Code/rqlasso.R

@@ -0,0 +1,74 @@
+library(caret)
+timestamp <- format(Sys.time(), "%Y_%m_%d_%H_%M")
+
+model <- "rqlasso"
+
+#########################################################################
+
+SLC14_1 <- function(n = 100) {
+  dat <- matrix(rnorm(n*20, sd = 3), ncol = 20)
+  foo <- function(x) x[1] + sin(x[2]) + log(abs(x[3])) + x[4]^2 + x[5]*x[6] + 
+    ifelse(x[7]*x[8]*x[9] < 0, 1, 0) +
+    ifelse(x[10] > 0, 1, 0) + x[11]*ifelse(x[11] > 0, 1, 0) + 
+    sqrt(abs(x[12])) + cos(x[13]) + 2*x[14] + abs(x[15]) + 
+    ifelse(x[16] < -1, 1, 0) + x[17]*ifelse(x[17] < -1, 1, 0) -
+    2 * x[18] - x[19]*x[20]
+  dat <- as.data.frame(dat)
+  colnames(dat) <- paste0("Var", 1:ncol(dat))
+  dat$y <- apply(dat[, 1:20], 1, foo) + rnorm(n, sd = 3)
+  dat
+}
+
+set.seed(1)
+training <- SLC14_1(30)
+testing <- SLC14_1(100)
+trainX <- training[, -ncol(training)]
+trainY <- training$y
+testX <- trainX[, -ncol(training)]
+testY <- trainX$y 
+
+rctrl1 <- trainControl(method = "cv", number = 3, returnResamp = "all")
+rctrl2 <- trainControl(method = "LOOCV")
+rctrl3 <- trainControl(method = "none")
+
+set.seed(849)
+test_reg_cv_model <- train(trainX, trainY, method = "rqlasso", trControl = rctrl1,
+                           preProc = c("center", "scale"))
+test_reg_pred <- predict(test_reg_cv_model, testX)
+
+
+set.seed(849)
+test_reg_cv_form <- train(y ~ ., data = training, 
+                          method = "rqlasso", trControl = rctrl1,
+                          preProc = c("center", "scale"))
+test_reg_pred_form <- predict(test_reg_cv_form, testX)
+
+
+set.seed(849)
+test_reg_loo_model <- train(trainX, trainY, method = "rqlasso", trControl = rctrl2,
+                            preProc = c("center", "scale"))
+
+set.seed(849)
+test_reg_none_model <- train(trainX, trainY, 
+                             method = "rqlasso", 
+                             trControl = rctrl3,
+                             tuneLength = 1,
+                             preProc = c("center", "scale"))
+test_reg_none_pred <- predict(test_reg_none_model, testX)
+
+#########################################################################
+
+test_reg_predictors1 <- predictors(test_reg_cv_model)
+
+#########################################################################
+
+tests <- grep("test_", ls(), fixed = TRUE, value = TRUE)
+
+sInfo <- sessionInfo()
+
+save(list = c(tests, "sInfo", "timestamp"),
+     file = file.path(getwd(), paste(model, ".RData", sep = "")))
+
+q("no")
+
+

RegressionTests/Code/rqnc.R

@@ -0,0 +1,74 @@
+library(caret)
+timestamp <- format(Sys.time(), "%Y_%m_%d_%H_%M")
+
+model <- "rqnc"
+
+#########################################################################
+
+SLC14_1 <- function(n = 100) {
+  dat <- matrix(rnorm(n*20, sd = 3), ncol = 20)
+  foo <- function(x) x[1] + sin(x[2]) + log(abs(x[3])) + x[4]^2 + x[5]*x[6] + 
+    ifelse(x[7]*x[8]*x[9] < 0, 1, 0) +
+    ifelse(x[10] > 0, 1, 0) + x[11]*ifelse(x[11] > 0, 1, 0) + 
+    sqrt(abs(x[12])) + cos(x[13]) + 2*x[14] + abs(x[15]) + 
+    ifelse(x[16] < -1, 1, 0) + x[17]*ifelse(x[17] < -1, 1, 0) -
+    2 * x[18] - x[19]*x[20]
+  dat <- as.data.frame(dat)
+  colnames(dat) <- paste0("Var", 1:ncol(dat))
+  dat$y <- apply(dat[, 1:20], 1, foo) + rnorm(n, sd = 3)
+  dat
+}
+
+set.seed(1)
+training <- SLC14_1(30)
+testing <- SLC14_1(100)
+trainX <- training[, -ncol(training)]
+trainY <- training$y
+testX <- trainX[, -ncol(training)]
+testY <- trainX$y 
+
+rctrl1 <- trainControl(method = "cv", number = 3, returnResamp = "all")
+rctrl2 <- trainControl(method = "LOOCV")
+rctrl3 <- trainControl(method = "none")
+
+set.seed(849)
+test_reg_cv_model <- train(trainX, trainY, method = "rqnc", trControl = rctrl1,
+                           preProc = c("center", "scale"))
+test_reg_pred <- predict(test_reg_cv_model, testX)
+
+
+set.seed(849)
+test_reg_cv_form <- train(y ~ ., data = training, 
+                          method = "rqnc", trControl = rctrl1,
+                          preProc = c("center", "scale"))
+test_reg_pred_form <- predict(test_reg_cv_form, testX)
+
+
+set.seed(849)
+test_reg_loo_model <- train(trainX, trainY, method = "rqnc", trControl = rctrl2,
+                            preProc = c("center", "scale"))
+
+set.seed(849)
+test_reg_none_model <- train(trainX, trainY, 
+                             method = "rqnc", 
+                             trControl = rctrl3,
+                             tuneGrid = test_reg_cv_form$bestTune,
+                             preProc = c("center", "scale"))
+test_reg_none_pred <- predict(test_reg_none_model, testX)
+
+#########################################################################
+
+test_reg_predictors1 <- predictors(test_reg_cv_model)
+
+#########################################################################
+
+tests <- grep("test_", ls(), fixed = TRUE, value = TRUE)
+
+sInfo <- sessionInfo()
+
+save(list = c(tests, "sInfo", "timestamp"),
+     file = file.path(getwd(), paste(model, ".RData", sep = "")))
+
+q("no")
+
+

models/files/rqlasso.R

@@ -0,0 +1,23 @@
+modelInfo <- list(label = "Quantile Regression with LASSO penalty",
+                  library = "rqPen",
+                  type = "Regression",
+                  parameters = data.frame(parameter = 'lambda',
+                                          class = "numeric",
+                                          label = 'L1 Penalty'),
+                  grid = function(x, y, len = NULL)
+                    expand.grid(lambda = c(10 ^ seq(-1, -4, length = len))),
+                  loop = NULL,
+                  fit = function(x, y, wts, param, lev, last, classProbs, ...) {
+                    rq.lasso.fit(as.matrix(x), y, lambda = param$lambda, ...)
+                    },
+                  predict = function(modelFit, newdata, submodels = NULL) {
+                    predict(modelFit, newx = as.matrix(newdata))[,1]
+                  },
+                  predictors = function(x, ...) {
+                    out <- coef(x)
+                    out <- out[names(out) != "intercept"]
+                    names(out)[out != 0]
+                  },
+                  tags = c("Linear Regression", "Quantile Regression", "Implicit Feature Selection", "L1 Regularization"),
+                  prob = NULL,
+                  sort = function(x) x[order(-x$lambda),])

models/files/rqnc.R

@@ -0,0 +1,26 @@
+modelInfo <- list(label = "Non-Convex Penalized Quantile Regression",
+                  library = "rqPen",
+                  type = "Regression",
+                  parameters = data.frame(parameter = c('lambda', 'penalty'),
+                                          class = c("numeric", "character"),
+                                          label =  c('L1 Penalty', 'Penalty Type')),
+                  grid = function(x, y, len = NULL)
+                    expand.grid(lambda = c(10 ^ seq(-1, -4, length = len)),
+                                penalty = c("MCP", "SCAD")),
+                  loop = NULL,
+                  fit = function(x, y, wts, param, lev, last, classProbs, ...) {
+                    rq.nc.fit(as.matrix(x), y, 
+                              lambda = param$lambda, 
+                              penalty = as.character(param$penalty), ...)
+                    },
+                  predict = function(modelFit, newdata, submodels = NULL) {
+                    predict(modelFit, newx = as.matrix(newdata))[,1]
+                  },
+                  predictors = function(x, ...) {
+                    out <- coef(x)
+                    out <- out[names(out) != "intercept"]
+                    names(out)[out != 0]
+                  },
+                  tags = c("Linear Regression", "Quantile Regression", "Implicit Feature Selection", "L1 Regularization"),
+                  prob = NULL,
+                  sort = function(x) x[order(-x$lambda),])

pkg/caret/inst/NEWS.Rd

@@ -10,6 +10,7 @@
 		\item Localized linear discriminant analysis (\code{method = "loclda"}) from the \cpkg{klaR} package was added. 
 		\item From the \cpkg{nnls} package, a model of the same name was added. 
 		\item Another linear SVM model from the \cpkg{e1071} package was added using \code{method = "svmLinear2"}
+		\item From the \cpkg{rqPen} package, quantile regression models \code{rqnc} and \code{rqlasso} were added. 
 		\item When specifying your own resampling indicies, a value of \code{method = "custom"} can be used with \code{trainControl} for better printing. 
 		\item Tim Lucas fixed a bug in \code{avNNet} when \code{bag = TRUE}
 		\item Fixed a bug found by ruggerorossi in \code{method = "dnn"} with classification.