Merge 381a357 into 1553656

RegressionTests/Code/regLogistic.R

@@ -0,0 +1,90 @@
+timestamp <- Sys.time()
+library(caret)
+
+model <- "regLogistic"
+
+rlGrid <- expand.grid( cost = c(200,2,0.02),
+                       loss = c("L1", "L2_dual", "L2_primal"),
+                       epsilon = c(0.001,0.01) )
+
+#########################################################################
+
+set.seed(2)
+training <- twoClassSim(50, linearVars = 2)
+testing <- twoClassSim(500, linearVars = 2)
+trainX <- training[, -ncol(training)]
+trainY <- training$Class
+
+cctrl1 <- trainControl(method = "cv", number = 3, returnResamp = "all",
+                       classProbs = TRUE, 
+                       summaryFunction = twoClassSummary)
+cctrl2 <- trainControl(method = "LOOCV",
+                       classProbs = TRUE, summaryFunction = twoClassSummary)
+cctrl3 <- trainControl(method = "none",
+                       classProbs = TRUE, summaryFunction = twoClassSummary)
+cctrlR <- trainControl(method = "cv", number = 3, returnResamp = "all", search = "random")
+
+set.seed(849)
+test_class_cv_model <- train(trainX, trainY, 
+                             method = "regLogistic", 
+                             trControl = cctrl1,
+                             metric = "ROC", 
+                             preProc = c("center", "scale"),
+                             tuneGrid = rlGrid)
+
+set.seed(849)
+test_class_cv_form <- train(Class ~ ., data = training, 
+                            method = "regLogistic", 
+                            trControl = cctrl1,
+                            metric = "ROC", 
+                            tuneGrid = rlGrid,
+                            preProc = c("center", "scale"))
+
+test_class_pred <- predict(test_class_cv_model, testing[, -ncol(testing)])
+test_class_prob <- predict(test_class_cv_model, testing[, -ncol(testing)], type = "prob")
+test_class_pred_form <- predict(test_class_cv_form, testing[, -ncol(testing)])
+test_class_prob_form <- predict(test_class_cv_form, testing[, -ncol(testing)], type = "prob")
+
+set.seed(849)
+test_class_rand <- train(trainX, trainY, 
+                         method = "regLogistic", 
+                         trControl = cctrlR,
+                         tuneLength = 4, 
+                         preProc = c("center", "scale"))
+
+set.seed(849)
+test_class_loo_model <- train(trainX, trainY, 
+                              method = "regLogistic", 
+                              trControl = cctrl2,
+                              metric = "ROC", 
+                              tuneGrid = rlGrid,
+                              preProc = c("center", "scale"))
+
+set.seed(849)
+test_class_none_model <- train(trainX, trainY, 
+                               method = "regLogistic", 
+                               trControl = cctrl3,
+                               tuneGrid = test_class_cv_model$bestTune,
+                               metric = "ROC",
+                               preProc = c("center", "scale"))
+
+test_class_none_pred <- predict(test_class_none_model, testing[, -ncol(testing)])
+test_class_none_prob <- predict(test_class_none_model, testing[, -ncol(testing)], type = "prob")
+
+test_levels <- levels(test_class_cv_model)
+if(!all(levels(trainY) %in% test_levels))
+  cat("wrong levels")
+
+#########################################################################
+
+tests <- grep("test_", ls(), fixed = TRUE, value = TRUE)
+
+sInfo <- sessionInfo()
+timestamp_end <- Sys.time()
+
+save(list = c(tests, "sInfo", "timestamp", "timestamp_end"),
+     file = file.path(getwd(), paste(model, ".RData", sep = "")))
+
+q("no")
+
+

models/files/regLogistic.R

@@ -0,0 +1,50 @@
+modelInfo <- list(label = "Regularized Logistic Regression",
+                  library = "LiblineaR",
+                  type = c ("Classification"),
+                  parameters = data.frame(parameter = c('cost', "loss", 'epsilon'),
+                                          class = c("numeric", "character", "numeric"),
+                                          label = c("Cost", "Loss Function", "Tolerance" )),
+                  grid = function(x, y, len = NULL, search = "grid") {
+                    if(search == "grid") {
+                      out <- expand.grid(cost = 2 ^((1:len)- ceiling(len*0.5)),
+                                         loss = c("L1", "L2_dual", "L2_primal"),
+                                         epsilon = signif(0.01 * (10^((1:len) - ceiling(len*0.5))), 2) )
+                    } else {
+                      out <- data.frame(cost = 2^runif(len, min = -10, max = 10),
+                                        loss = sample(c("L1", "L2_dual", "L2_primal"), size = len, replace = TRUE),
+                                        epsilon = 1^runif(len, min=-10, max= 10))
+                    }
+                    out
+                  }, 
+                  loop = NULL,
+                  fit = function(x, y, wts, param, lev, last, classProbs, ...) {
+
+		    if( !(param$loss %in% c( "L1", "L2_dual", "L2_primal")) ) {
+                      stop("Loss function is not recognised.")
+                    }
+                    if(!is.factor(y)) {
+                      stop('y is not recognised as a factor')
+                    }
+                    model_type = ifelse( param$loss == "L1", 6, ifelse( param$loss == "L2_primal", 0, 7))
+                    out <- LiblineaR(data = as.matrix(x), target = y,
+                                     cost = param$cost, epsilon = param$epsilon,
+                                     type = model_type,
+                                     ...)
+
+                    out
+                  },
+                  predict = function(modelFit, newdata, submodels = NULL) {
+                    predict(modelFit, newdata)$predictions
+                  },
+                  prob = function(modelFit, newdata, submodels = NULL){
+                    predict(modelFit,newdata, proba = TRUE)$probabilities
+                  },
+                  predictors = function(x, ...) { 
+                    out <- colnames(x$W)
+                    out[out != "Bias"]
+                    },
+                  tags = c("Linear Classifier", "Robust Methods", "L1 Regularization", "L2 Regularization"),
+                  levels = function(x) x$levels,
+                  sort = function(x) {
+                    x[order(x$cost),]
+                  })