```{r startup,echo=FALSE,results='hide',message=FALSE}
## knit("GA.Rmd", "GA1.md")
library(caret)
library(ggplot2)
library(reshape2)
library(RColorBrewer)
library(GA)
library(pROC)
library(desirability)
library(MASS)
# library(doMC)
# registerDoMC(15)

load("ga1.RData")

twoClassSim <- function(n = 100, 
                        intercept = -5,
                        linearVars = 10,
                        noiseVars = 0,    ## Number of uncorrelated x's
                        corrVars = 0,     ## Number of correlated x's
                        corrType = "AR1", ## Corr structure ('AR1' or 'exch')
                        corrValue = 0)    ## Corr parameter)
{
  require(MASS)
  sigma <- matrix(c(2,1.3,1.3,2),2,2)
  
  tmpData <- data.frame(mvrnorm(n=n, c(0,0), sigma))
  names(tmpData) <- paste("TwoFactor", 1:2, sep = "")
  if(linearVars > 0)
  {
    tmpData <- cbind(tmpData, matrix(rnorm(n*linearVars), ncol = linearVars))
    colnames(tmpData)[(1:linearVars)+2] <- paste("Linear", gsub(" ", "0", format(1:linearVars)), sep = "")
  }
  tmpData$Nonlinear1 <- runif(n, min = -1)
  tmpData <- cbind(tmpData, matrix(runif(n*2), ncol = 2))
  colnames(tmpData)[(ncol(tmpData)-1):ncol(tmpData)] <- paste("Nonlinear", 2:3, sep = "")
  
  tmpData <- as.data.frame(tmpData)
  p <- ncol(tmpData)
  
  if(noiseVars > 0)
  {
    tmpData <- cbind(tmpData, matrix(rnorm(n * noiseVars), ncol = noiseVars))
    colnames(tmpData)[(p+1):ncol(tmpData)] <- paste("Noise", 
                                                    gsub(" ", "0", format(1:noiseVars)), 
                                                    sep = "")
  }
  if(corrVars > 0)
  {
    p <- ncol(tmpData)
    library(nlme)
    library(MASS)
    if(corrType == "exch")
    {
      vc <- corCompSymm(value = corrValue, form = ~ 1 | vars)
      vc <- Initialize(vc, data = data.frame(vars = rep(letters[1], each = noiseVars)))
      vc <- as.matrix(vc)
    }
    if(corrType == "AR1")
    {
      vc <- corAR1(value = corrValue, form = ~ 1 | vars)
      vc <- Initialize(vc, data = data.frame(vars = rep(letters[1], each = corrVars)))
      vc <- as.matrix(vc)
    }    
    tmpData <- cbind(tmpData, mvrnorm(n, mu = rep(0, corrVars), Sigma = vc))
    colnames(tmpData)[(p+1):ncol(tmpData)] <- paste("Corr", 
                                                    gsub(" ", "0", format(1:corrVars)), 
                                                    sep = "")
  }  
  lp <- intercept -
    4 * tmpData$TwoFactor1 + 4*tmpData$TwoFactor2 + 
    2*tmpData$TwoFactor1*tmpData$TwoFactor2 + 
    (tmpData$Nonlinear1^3) + 2 * exp(-6*(tmpData$Nonlinear1 - 0.3)^2) +
    2*sin(pi*tmpData$Nonlinear2* tmpData$Nonlinear3) 
  
  if(linearVars > 0)
  {
    lin <- seq(10, 1, length = linearVars)/4 
    lin <- lin * rep(c(-1, 1), floor(linearVars)+1)[1:linearVars] 
    for(i in seq(along = lin)) lp <- lp + tmpData[, i+3]*lin[i]
  }
  
  prob <- binomial()$linkinv(lp)
  tmpData$Class <- ifelse(prob <= runif(n), "Class1", "Class2")
  tmpData$Class <- factor(tmpData$Class, levels = c("Class1", "Class2"))
  
  tmpData
}
getLarge <- function(ind, x, y, large, test, cntrl)
{
  cntrl$verboseIter <- FALSE
  cntrl$allowParallel <- TRUE
  modFit <- train(x[,ind], y,
                  method = "qda",
                  metric = "ROC",
                  trControl = cntrl)
  testROC <- roc(test$Class, 
                 predict(modFit,test[,ind,drop = FALSE],type = "prob")[,1], 
                 levels = rev(levels(y)))
  
  largeROC <- roc(large$Class, 
                  predict(modFit, large[,ind,drop = FALSE], type = "prob")[,1], 
                  levels = rev(levels(y)))  
  dROC <- dMax(.5, 1)
  dPreds <- dMin(1, ncol(x))
  allD <- dOverall(dROC, dPreds)
  D_CV <- predict(allD, data.frame(ROC = caret:::getTrainPerf(modFit)[1,"TrainROC"], 
                                   NumPred = length(ind)))
  D_Test <- predict(allD, data.frame(ROC = as.vector(auc(testROC)), 
                                   NumPred = length(ind))) 
  D_Large_Sample <- predict(allD, data.frame(ROC = as.vector(auc(largeROC)), 
                                   NumPred = length(ind)))    
  c(D_CV = D_CV,
    D_Test = D_Test,
    D_Large_Sample = D_Large_Sample,
    Resampling = caret:::getTrainPerf(modFit)[1,"TrainROC"],
    Test = as.vector(auc(testROC)), 
    Large_Sample = as.vector(auc(largeROC)),
    Size = length(ind),
    NumLin = sum(ind %in% 1:12),
    NumNonLin = sum(ind %in% 13:15),
    NumUnCorr = sum(ind %in% 16:115),
    NumCorr = sum(ind %in% 116:215))
}
getLarge_test <- function(ind, x, y, large, test)
  {
  modFit <- qda(x[,ind], y)
  testROC <- roc(test$Class, 
                 predict(modFit, test[,ind,drop = FALSE])$posterior[,1], 
                 levels = rev(levels(y)))
  
  largeROC <- roc(large$Class, 
                  predict(modFit, large[,ind,drop = FALSE])$posterior[,1], 
                  levels = rev(levels(y)))                 
  c(Test = as.vector(auc(testROC)), 
    Large_Sample = as.vector(auc(largeROC)),
    Size = length(ind),
    NumLin = sum(ind %in% 1:12),
    NumNonLin = sum(ind %in% 13:15),
    NumUnCorr = sum(ind %in% 16:115),
    NumCorr = sum(ind %in% 116:215))
  }
rocColors <- c("black", "grey", brewer.pal(8,"Dark2"))
```

Previously, I talked about genetic algorithms (GA) for feature selection and illustrated the algorithm using a modified version of the [GA](http://cran.r-project.org/web/packages/GA/index.html) R package and [simulated data](http://appliedpredictivemodeling.com/blog/2013/4/11/a-classification-simulation-system). The data were simulated with 200 non-informative predictors and 12 linear effects and three non-linear effects. Quadratic discriminant analysis (QDA) was used to model the data. The [last set of analyses](http://appliedpredictivemodeling.com/blog/2013/4/29/feature-selection-strikes-back-part-1) showed, _for these data_, that:

* The performance of QDA suffered from including the irrelevant terms.
* Using a resampled estimate area under the ROC curve resulted in selection bias and severely over-fit to the predictor set.
* Using a single test set to estimate the fitness value did marginally better model with an area under the ROC curve of 0.622.
* Recursive feature elimination (RFE) was also used and found a much better predictor subset with good performance (an AUC of 0.885 using the large-sample data set).

For the genetic algorithm, I used the default parameters (e.g. crossover rate, mutation probability etc). Can we do better with GA's? 

One characteristic seen in the last set of analyses is that, as the number of irrelevant predictors increases, there is a gradual decrease in the fitness value (although the true performance gets worse). The initial population of chromosomes for the GA is based on simple random sampling, which means that each predictor has about a 50% chance of being included. Since our true subset is much smaller, the GA should favor smaller sets and move towards cases with fewer predictors... except that it didn't. I think that this didn't happen because the of two reasons:

1. The increase in performance caused by removing a single predictor is small. Since there is no "performance cliff" for this model, the GA isn't able to see improvements in performance unless a subset is tested with a very low number of predictors.

2. Clearly, using the evaluation set and resampling to measure the fitness value did not penalize larger models enough. The plots of these estimates versus the large sample estimates showed that they were not effective measurements. Note that the RFE procedure did not have this issue since the feature selection was conducted within the resampling process (and reduced the effect of selection bias).

Would resampling the entire GA process help? It might but I doubt it. It only affects how performance is measured and does not help the selection of features, which is the underlying issue. I think it would result in another over-fit model and all that the resampling would do would be to accurately tell when the model begins to over-fit. I might test this hypothesis in another post.

There are two approaches that I'll try here to improve the effectiveness of the GA. The first is to modify the initial population. If we have a large number of irrelevant predictors in the model, the GA has difficultly driving the number of predictors down. However, would the converse be true? We are doing feature selection. Why not start the GA with a set of chromosomes with small predictor sets. Would the algorithm drive up the number of predictors or would it see the loss of performance and keep the number small?

To test this, I simulated the same data sets:

```{r data,cache=TRUE}
set.seed(468)
training <- twoClassSim(  500, noiseVars = 100, corrVar = 100, corrValue = .75)
testing  <- twoClassSim(  500, noiseVars = 100, corrVar = 100, corrValue = .75)
large    <- twoClassSim(10000, noiseVars = 100, corrVar = 100, corrValue = .75)
realVars <- names(training)
realVars <- realVars[!grepl("(Corr)|(Noise)", realVars)]
cvIndex <- createMultiFolds(training$Class, times = 2)
ctrl <- trainControl(method = "repeatedcv",
                     repeats = 2,
                     classProbs = TRUE,
                     summaryFunction = twoClassSummary,
                     allowParallel = FALSE,
                     index = cvIndex)
```

The `ga` function has a parameter for creating the initial population. I'll use one that produces chromosomes with a random 10% of the predictors. 

```{r smallFunc}
initialSmall <- function (object, ...) 
  {
  population <- sample(0:1, replace = TRUE, 
                       size = object@nBits*object@popSize, 
                       prob = c(.9, .1))
  population <- matrix(population, nrow = object@popSize, ncol = object@nBits)
  return(population)
  }
```

Then I'll run the GA again. 


```{r ga_with_small_cv,message=FALSE,results='hide',cache=TRUE}
ROCcv <- function(ind, x, y, cntrl)
  {
  library(caret)
  library(MASS)
  ind <- which(ind == 1)
  ## In case no predictors are selected:
  if(length(ind) == 0) return(0)
  out <- train(x[,ind], y, method = "qda",
               metric = "ROC", trControl = cntrl)
  caret:::getTrainPerf(out)[, "TrainROC"]
  }
set.seed(137)
ga_small_cv <- ga(type = "binary",
                  fitness = ROCcv,
                  min = 0, max = 1,
                  maxiter = 400,
                  population = initialSmall,
                  nBits = ncol(training) - 1,
                  names = names(training)[-ncol(training)],
                  x = training[,-ncol(training)],
                  y = training$Class,
                  cntrl = ctrl,
                  keepBest = TRUE,
                  parallel = FALSE)
```
```{r small_cv_results,message=FALSE,results='hide',cache=TRUE}
small_cv_results <- lapply(ga_small_cv@bestBinary, 
                           getLarge, 
                           x = training[,-ncol(training)], 
                           y = training$Class, 
                           large = large, 
                           test = testing,
                           cntrl = ctrl)
small_cv_results <- do.call("rbind", small_cv_results)
small_cv_results <- as.data.frame(small_cv_results)
small_cv_results$Generation <- 1:nrow(small_cv_results)
small_cv_vert <- melt(small_cv_results, measure.vars = c("Resampling", "Test", "Large_Sample"))
small_cv_vert$variable <- factor(as.character(small_cv_vert$variable),
                                 levels = c("Resampling", "Test", "Large_Sample"))
total_vars_small_cv <- sum(ga_small_cv@solution[1,]==1)
num_lin_small_cv <- sum(ga_small_cv@solution[1,grepl("Linear", colnames(ga_small_cv@solution))]==1)
num_nlin_small_cv <- sum(ga_small_cv@solution[1,grepl("Nonlinear", colnames(ga_small_cv@solution))]==1)
num_int_small_cv <- sum(ga_small_cv@solution[1,grepl("TwoFactor", colnames(ga_small_cv@solution))]==1)
if(num_int_small_cv == 2) num_int_small_cv <- "both"
```

The genetic algorithm converged on a subset size of `r I(total_vars_small_cv)` predictors. This included `r I(num_lin_small_cv)` of the 10 linear predictors, `r I(num_nlin_small_cv)` of the non-linear terms and `r I(num_int_small_cv)` of the terms that have an interaction effect in the model. The trends were:

```{r plot_small_cv,fig.height=6,fig.width=10,echo=FALSE}
qplot(Generation, value, 
      data = small_cv_vert, 
      color = variable, 
      size = Size,
      ylab = "Area Under the ROC Curve") + colScale
```

The resampling and the large sample results have the same pattern until about 75 iterations, after which point they agree in some areas and disagree in others. However the genetic algorithm begins to over-fit to the predictors. The resampling results do not reflect this but the test set would have picked up the issue. 

Applying the resulting model to the large-sample set, the ROC curve is shown below along with the curves from the previous analysis.

```{r small_cv_ROC,cache=TRUE}
small_cv_Vars <- ga_small_cv@bestBinary[[length(ga_small_cv@bestBinary)]]
small_cv_Fit <- qda(training[,small_cv_Vars], training$Class)
small_cv_Large <- roc(large$Class, 
                      predict(small_cv_Fit, large[, small_cv_Vars])$posterior[,1], 
                      levels = rev(levels(large$Class)))

```

```{r rocPlotSmall,results='hide',message=FALSE,echo=FALSE}
plot(trueLarge, col = rocColors[1], lwd = 2)
plot(fullLarge, col = rocColors[2], lwd = 2, lty = 2, add = TRUE)
plot(rfeLarge, col = rocColors[3], lwd = 2, add = TRUE)
plot(small_cv_Large, col = rocColors[4], lwd = 2, add = TRUE)

legend(.4, .5, c("Correct Predictors", "All Predictors", "RFE", "Genetic Algo (Small)"), 
       col = rocColors[1:4],
       lwd = rep(2,4), lty = c(1, 2, 1, 1))

```

Starting from small subset sizes appeared to have helped. Would using the evaluation set to estimate the fitness have had the same results? 

```{r test_print}
ROCtest <- function(ind, x, y, cntrl, test)
  {
  library(MASS)
  ind <- which(ind == 1)
  if(length(ind) == 0) return(0)
  modFit <- qda(x[,ind], y)
  testROC <- roc(test$Class, 
                 predict(modFit, test[,ind,drop = FALSE])$posterior[,1], 
                 levels = rev(levels(y)))
  as.vector(auc(testROC))
  }
```

```{r ga_with_small_set,message=FALSE,results='hide',cache=TRUE}
set.seed(137)
ga_small <- ga(type = "binary",
               fitness = ROCtest,
               min = 0, max = 1,
               maxiter = 400,
               population = initialSmall,
               nBits = ncol(training) - 1,
               names = names(training)[-ncol(training)],
               x = training[,-ncol(training)],
               y = training$Class,
               cntrl = ctrl,
               test = testing,
               keepBest = TRUE,
               parallel = FALSE)
```

```{r small_results,message=FALSE,results='hide',cache=TRUE}
small_results <- lapply(ga_small@bestBinary, 
                        getLarge_test, 
                        x = training[,-ncol(training)], 
                        y = training$Class, 
                        large = large, 
                        test = testing)
small_results <- do.call("rbind", small_results)
small_results <- as.data.frame(small_results)
small_results$Generation <- 1:nrow(small_results)
small_vert <- melt(small_results, measure.vars = c("Test", "Large_Sample"))
small_vert$variable <- factor(as.character(small_vert$variable),
                              levels = c("Resampling", "Test", "Large_Sample"))

## factor levels are dropped by ggplot2!
## see http://tinyurl.com/co6e9fv
myColors <- brewer.pal(5,"Set1")
names(myColors) <- levels(small_vert$variable)
colScale <- scale_colour_manual(name = "grp",values = myColors)

```

```{r small_ROC,cache=TRUE}
smallVars <- ga_small@bestBinary[[length(ga_small@bestBinary)]]
smallFit <- qda(training[,smallVars], training$Class)
smallLarge <- roc(large$Class, 
                  predict(smallFit, large[, smallVars])$posterior[,1], 
                  levels = rev(levels(large$Class)))

```

This GA showed:

```{r plot_small,fig.height=6,fig.width=10,echo=FALSE}
qplot(Generation, value, 
      data = small_vert, 
      color = variable, 
      size = Size,
      ylab = "Area Under the ROC Curve") + colScale
```

The pattern is very similar to the previous GA run (where resampling was used).

Given that the resampling process is susceptible to over-fitting, how can we penalize the results based on the size of the subset? The idea of penalization/_regularization_ is pretty common in statistics and machine learning. The most commonly known measure is the [Akaike information criterion](https://www.google.com/search?q=%22Akaike+information+criterion%22&aq=f&oq=%22Akaike+information+criterion%22) (AIC) which takes the objective function that is being optimized (e.g. RMSE or likelihood) and penalizes it based on the sample size and number of parameters. That's not very straight-forward here. First, it is very model dependent. In many cases, the number of parameters is not a useful concept. What would be use for tree-based models? In ensemble models, there may be more parameters than data points. What is the objective function? I've been trying to optimize the area under the ROC curve, but there is not theoretical connection between the ROC curve and QDA. QDA can be motivated by Bayes' Rule and, if a probability distribution is specified, it is for the predictor data. 

One less theoretical solution uses [desirability functions](https://www.google.com/search?q=desirability+functions). This technique is used to blend several outcomes into a single measure of _desirability_. In our case, I want to maximize the area under the ROC curve but minimize the number of predictors in the model. The desirability function first defines curves that translates both of these characteristics to a [0, 1] scale where zero is unacceptable and one is desirable. Any curve can do. I'll use the parameterization created by [Derringer and Suich](https://www.google.com/search?q=%22Simultaneous+optimization+of+several+response+variables%22) that defines high and low thresholds for each characteristic and linearizes the desirability in-between those values:

```{r Dplot,fig.height=6,fig.width=10}
library(desirability)
## The best ROC value is one, 0.5 is the worst
dROC <- dMax(low = .5, high = 1)
## The "best" possible model would have a single predictor
## and the worst would have everything
dPreds <- dMin(low = 1, high = ncol(training)-1)
## Show them:
par(mfrow = c(1, 2))
plot(dROC, nonInform = FALSE)
title("Area Under the ROC Curve")
plot(dPreds, nonInform = FALSE)
title("Subset Size")
```

The ROC desirability curve is maximized when the area under the curve is high while the subset size curve is most desirable for small values. I can adjust the thresholds a several different ways. For example, I may only want subset sizes less than 100. If I move the `high` value to 100, any solution with less than 100 predictors would be equally acceptable. Another modification is to allow the curves to bend to make each characteristic easier or more difficult to satisfy. The SAS application JMP has a nice tool for configuring desirability functions (obviously, I used an R package above to create them).

The overall desirability is the geometric mean of the individual desirabilites. For two inputs, I multiply them together and take the square root. Since I've multiplied the values together, one consequence is that the overall desirability is unacceptable if any one of the individual values is unacceptable (i.e. a value of zero). This can be avoided by adjusting the individual curve to always be higher than a desirability of zero. 

We can then maximize the overall desirability and hope that the GA can find a balance between performance and sparsity. I'll define a new fitness function that uses overall desirability as measured with the resampled estimate of the area under the ROC curve:

```{r D}
Dcv <- function(ind, x, y, cntrl)
{
  library(caret)
  library(MASS)
  library(desirability)
  ind <- which(ind == 1)
  if(length(ind) == 0) return(0)
  out <- train(x[,ind], y, method = "qda", metric = "ROC", trControl = cntrl)
  rocVal <- caret:::getTrainPerf(out)[, "TrainROC"]
  dROC <- dMax(.5, 1)
  dPreds <- dMin(1, ncol(x))
  ## Comnined the two with a geometirc mean
  allD <- dOverall(dROC, dPreds)
  ## Calculate the overall desirability value
  predict(allD, data.frame(ROC = rocVal, NumPred = length(ind)))
}
```

Any I will once again use the `GA` package to search the predictor space:

```{r ga_D,message=FALSE,results='hide',cache=TRUE}
set.seed(137)
ga_D <- ga(type = "binary",
           fitness = Dcv,
           min = 0, max = 1,
           maxiter = 500,
           population = initialSmall,
           nBits = ncol(training) - 1,
           names = names(training)[-ncol(training)],
           x = training[,-ncol(training)],
           y = training$Class,
           cntrl = ctrl,
           keepBest = TRUE,
           parallel = FALSE)
```

```{r d_results,message=FALSE,results='hide',cache=TRUE}
resamp_results <- lapply(ga_D@bestBinary, 
                         getLarge, 
                         x = training[,-ncol(training)], 
                         y = training$Class, 
                         large = large, 
                         test = testing, 
                         cntrl = ctrl)
resamp_results <- do.call("rbind", resamp_results)
resamp_results <- as.data.frame(resamp_results)
resamp_results$Generation <- 1:nrow(resamp_results)
resamp_vert_ROC <- melt(resamp_results, 
                        measure.vars = c("Resampling", "Test", "Large_Sample"))
resamp_vert_D <- melt(resamp_results, 
                      measure.vars = c("D_CV", "D_Test", "D_Large_Sample"))
```

```{r d_vars,message=FALSE,results='hide',cache=TRUE}
total_vars_desire <- sum(ga_D@solution[1,]==1)
num_lin_desire <- sum(ga_D@solution[1,grepl("Linear", colnames(ga_D@solution))]==1)
num_nlin_desire <- sum(ga_D@solution[1,grepl("Nonlinear", colnames(ga_D@solution))]==1)
num_int_desire <- sum(ga_D@solution[1,grepl("TwoFactor", colnames(ga_D@solution))]==1)
if(num_int_desire == 2) num_int_desire <- "both"
if(num_nlin_desire == 0) num_nlin_desire <- "none"
num_noise_desire <- sum(ga_D@solution[1,grepl("(Corr)|(Noise)", colnames(ga_D@solution))]==1)
```

Here are the profiles for the three estimates of desirability (symbols sizes again indicate the subset size):

```{r plotD,fig.height=6,fig.width=10,echo=FALSE}
qplot(Generation, value, 
      data = resamp_vert_D, 
      color = variable, 
      size = Size,
      ylab = "Desirability")
```

The first pattern to note is that all three estimates are strongly correlated. There seems to be negligable evidence of selection bias creeping in as before. The GA converged to a fairly small subset size.  The genetic algorithm converged on a subset size of `r I(total_vars_desire)` predictors. This included `r I(num_lin_desire)` of the 10 linear predictors, `r I(num_nlin_desire)` of the non-linear terms, `r I(num_int_desire)` of the terms that have an interaction effect in the model and  `r I(num_noise_desire)` irrelavant predictors.

```{r plotROC,fig.height=6,fig.width=10,echo=FALSE}
qplot(Generation, value, 
      data = resamp_vert_ROC, 
      color = variable, 
      size = Size,
      ylab = "Area Under the ROC Curve")
```

In terms of the area under the ROC curve, the GA was able to produce pretty competitive performance:

```{r final_test_model,cache=TRUE}
finalDVars <- ga_D@bestBinary[[length(ga_D@bestBinary)]]
finalDFit <- qda(training[,finalDVars], training$Class)
finalDLarge <- roc(large$Class, 
                  predict(finalDFit, large[, finalDVars])$posterior[,1], 
                  levels = rev(levels(large$Class)))
finalDLarge
```

The resampling results are slightly optimistic and the test set is slightly pessimistic. The large-sample estimate of the area under the ROC curve is `r I(round(as.vector(auc(finalLarge)),3))`, which is not as good as the true model (`r I(signif(auc(trueLarge), 3))`) but better than the worst-case scenario (`r I(signif(auc(fullLarge), 3))`). The ROC curves are:

```{r rocPlotFinal,results='hide',message=FALSE,echo=FALSE}
# load("ga1.RData")
plot(trueLarge, col = rocColors[1], lwd = 2)
plot(fullLarge, col = rocColors[2], lwd = 2, lty = 2, add = TRUE)
plot(rfeLarge, col = rocColors[3], lwd = 2, add = TRUE)
plot(smallLarge, col = rocColors[4], lwd = 2, add = TRUE)
plot(finalDLarge, col = rocColors[5], lwd = 2, add = TRUE)

legend(.4, .5, c("Correct Predictors", "All Predictors", "Genetic Algo (Small)", 
                 "RFE", "Genetic Algo (D)"), 
       col = rocColors[1:5],
       lwd = rep(2,5), lty = c(1, 2, 1, 1, 1))

```

So this approach is yielding near-optimal results. 

As I did in the last post, I'm compelled to throw a wet blanket on all of this. Last time, I showed that, for these data, the RFE procedure was more effective than the GA. With the two adjustments I made to the GA, it has the performance edge. What if I were to use a classification model with built-in feature selection? One such approach is the [Flexible Discriminant Model (FDA)](http://scholar.google.com/scholar?hl=en&q=Flexible+Discriminant+Model). FDA is a generalizes of linear discriminant analysis that can produce non-linear class boundaries. It does this using a framework that generalizing the basis functions that can be used. One approach is to use [Multivariate Adaptive Regression Splines (MARS)](http://scholar.google.com/scholar?q=multivariate+adaptive+regression+splines) to fit the model. MARS is a regression model that has one quality in common with tree-based models; MARS chooses one or more predictor to "split" on. Multiple splits are used to model different predictors, but if a predictor was never used in a split, the class boundaries are functionally independent of that predictor. So, FDA simultaneously builds a classification model while conducting feature selection. This is computationally advantageous (less models are being fit), less likely to over-fit and ties the feature selection process directly to model performance. 

I fit an FDA model with MARS basis functions. There are two tuning parameters. First, the _degree_ of the model indicates the maximum number of predictors that can be used in a split. I'll evaluate only first or second degree models. The other parameter is the number of retained terms. MARS does a forward stage of splitting then, like tree models, _prunes_ the model terms. The `nprune` parameter controls how far MARS can reduce the complexity of the model.

I'll use [caret package](http://caret.r-forge.r-project.org/)'s `train` function again with the same cross-validation scheme:

```{r fda_fit,cache=TRUE}
## I'll use parallel processing to fit the model
ctrl$allowParallel <- TRUE
fdaModel <- train(Class ~ ., 
                  data = training,
                  method = "fda",
                  tuneGrid = expand.grid(.nprune = 2:30, .degree = 1:2),
                  metric = "ROC",
                  trControl = ctrl)
fdaTest <- roc(testing$Class, 
               predict(fdaModel, testing, type = "prob")[,1], 
               levels = rev(levels(testing$Class)))
fdaTest

fdaLarge <- roc(large$Class, 
                predict(fdaModel, large, type = "prob")[,1], 
                levels = rev(levels(testing$Class)))
fdaLarge 
  
```

The resampling profile for this model was:

```{r fda_profile,fig.height=6,fig.width=10,echo=FALSE}
trellis.par.set(caretTheme())
plot(fdaModel)
```

The model used additive functions of the predictor data (which may result in an interpretable model). The ROC curves:

```{r rocPlotFda,results='hide',message=FALSE,echo=FALSE}
plot(trueLarge, col = rocColors[1], lwd = 2)
plot(fullLarge, col = rocColors[2], lwd = 2, lty = 2, add = TRUE)
plot(rfeLarge, col = rocColors[3], lwd = 2, add = TRUE)
plot(smallLarge, col = rocColors[4], lwd = 2, add = TRUE)
plot(finalDLarge, col = rocColors[5], lwd = 2, add = TRUE)
plot(fdaLarge, col = rocColors[6], lwd = 2, add = TRUE)

legend(.4, .5, c("Correct Predictors", "All Predictors", "Genetic Algo (Small)", 
                 "RFE", "Genetic Algo (D)", "FDA"), 
       col = rocColors[1:6],
       lwd = rep(2,6), lty = c(1, 2, 1, 1, 1,1))

```

The results indicate that a single FDA model does better than the best possible QDA model and the model fitting process was much model simplistic and straight-forward _for these data_. This may not always be true. This simulation system has non-linear terms that QDA should not be able to model (and FDA/MARS can), so it is not a completely fair comparison.

The code for these analyses can be found **here.**

The next post in this series looks at another wrapper-based feature selection algorithm: particle swarm optimization. 

```{r save,results='hide',message=FALSE,echo=FALSE}
## Save these for the next blog post
save(rfeLarge, fullLarge, trueLarge, finalLarge, 
     fdaLarge, finalDLarge, small_cv_Large,
     file = "ga2.RData")
```
