Nothing
svmfs <- function (x, ...)
UseMethod ("svmfs")
`svmfs.default` <-
function(x,y,
fs.method = c("scad", "1norm", "scad+L2", "DrHSVM"),
# chose the search method for lambda1,2: 'interval' or 'discrete'
grid.search=c("interval","discrete"),
### tuning parameter settings
#fixed grid for lambda1, lambda2
lambda1.set=NULL,
lambda2.set=NULL,
# define range for lambda1,2 for interval search
bounds=NULL,
# parms.coding="none" or "log2"
parms.coding= c("log2","none"),
# internal parameter for DIRECT
maxevals=500,
### valuidation settings
# fot nested validation, 'cross.outer'-fold cv
#cross.outer= 0,
# method for the inner validation: cross validation, gacv
inner.val.method = c("cv", "gacv"),
# 'cross.inner'-fold cv
cross.inner= 5,
# show plots in Direct?
show= c("none", "final"),
### other settings
# internal parameter for svm
calc.class.weights=FALSE,
class.weights=NULL,
#seed
seed=123,
# max Iterations for the feature selection svm method
maxIter=700,
# verbose?
verbose=TRUE,
...){
## Input:
# x: n-by-d data matrix to train (n chips/patients, d clones/genes, d>>n )
# y: column vector (or factor vector) of target {-1, 1}'s (for n chips/patiens )
# lam2.range : lambda2 range for elastic net (DrHSVM)
# feature selection - L1 or 1norm svm
#require(MCRestimate)
print("grid search")
print(grid.search)
print("show")
print(show)
#require(lhs)# - Latin Hypercube sampling function
#require(tgp)# for GP
#require(mlegp)
possible.fs<-c("1norm", "scad", "scad+L2", "DrHSVM")
nn<-length(y) # number of cases (patients)
nlevels.class<- nlevels(as.factor(y))
levels.class <- levels(as.factor(y))
# check labels y
if (!all((levels(factor(y)) == c("-1","1"))) ) stop ("labels y should be -1 and 1.")
# check for 1norm
if (fs.method == "1norm" & inner.val.method == "gacv" ) stop("gacv is not availible for 1norm SVM. Use k fold cv instead.")
#check bounds
if (grid.search=="interval"){
# for SCAD or L1 norm
if ((fs.method %in% c("scad", "1norm" )) & is.null(bounds)){
bounds=t(data.frame(log2lambda1=c(-10, 10)))
colnames(bounds)<-c("lower", "upper")
}
# for Elastic Net
if (fs.method %in% c("DrHSVM") & is.null(bounds)){
bounds=t(data.frame(log2lambda2=c(-10, 10)))
colnames(bounds)<-c("lower", "upper")
}
# for Elastic SCAD
if (fs.method %in% c("scad+L2") & is.null(bounds)){
bounds=t(data.frame(log2lambda1=c(-10, 10), log2lambda2=c(-10,10)))
colnames(bounds)<-c("lower", "upper")
}
# for scad
if (calc.class.weights){
class.weights = 100/ table(y)
}else class.weights = NULL
}
possible.inner.val.method<-c("gacv", "cv")
if (! (inner.val.method %in% possible.inner.val.method )) stop(paste("You have to use one of following (inner) validation methods:",
paste(possible.inner.val.method, collapse=", ")))
#checks
if (! (fs.method %in% possible.fs )) stop(paste("You have to use one of following fecture selection methods:",
paste(possible.fs, collapse=", ")))
print(paste("feature selection method is", fs.method))
# # if cross.outer>0 use outer cv !!!!! TODO
# if(cross.outer>0){
# print(paste("Apply outer ", cross.outer, "-fold cross validation ", sep="" ))
# res.cv<- .run.cv(x=x,y=y, lambda1.set=lambda1.set, lambda2.set=lambda2.set, bounds=bounds, cross.outer=cross.outer, class.weights=class.weights, seed=seed)
# print("outer cross validation done...")
# } # end of if cross.outer>0 ###
########################################################################################
# create final model
# set seed again
if (!is.null(seed)) set.seed(seed)
if (grid.search=="interval") {
model<-.run.interval(x=x,y=y, fs.method=fs.method, bounds=bounds,parms.coding=parms.coding,
class.weights=class.weights, maxevals=maxevals, seed=seed,
maxIter=maxIter, show=show, inner.val.method=inner.val.method, cross.inner=cross.inner, verbose=verbose)
}
if (grid.search=="discrete") {
model<-.run.discrete(x=x,y=y, fs.method=fs.method,
lambda1.set=lambda1.set,
lambda2.set=lambda2.set,
parms.coding=parms.coding,
class.weights=class.weights,
maxevals=maxevals,
seed=seed,
maxIter=maxIter,
show=show,
inner.val.method=inner.val.method,
cross.inner=cross.inner,
verbose=verbose)
}
#######################################################################################
# if no outer cv is done, no correct.prediction results ;-)
# if (cross.outer == 0) {
# rv <- list(classes=as.factor(y),
# sample.names = names(y),
# class.method=paste("svm",fs.method ),
# cross.outer=cross.outer,
# seed = seed,
# model =model,
# lambda1.set=lambda1.set,
# lambda2.set=lambda2.set,
# bounds=bounds,
# inner.val.method = inner.val.method,
# cross.inner= cross.inner,
# cv.info = models.info.sort,
# discrete.fit =discrete.fit )
# if (inner.val.method != "cv") rv$cross.inner =NULL
# } else {
# ## all data are collected
# rv <- list(votes=res.cv$vote.table,
# classes=as.factor(y),
# table=res.cv$confusion,
# #sample.names = rownames(vote.matrix),
# sample.names = names(y),
# gene.names = colnames(x),
# correct.prediction=res.cv$res$correct.prediction,
# correct.class.vote=res.cv$res$correct.class.vote,
# class.method=paste("svm",fs.method ),
# cross.outer=cross.outer,
# seed = seed,
# #cross.repeat=cross.repeat,
# #sample.names=sample.names,
# model =model,
# lambda1.set=lambda1.set,
# lambda2.set=lambda2.set,
# bounds=bounds,
# inner.val.method = inner.val.method,
# cross.inner= cross.inner
# ,cv.info=res.cv$model.info.list
# ,discrete.fit =discrete.fit
# )
# if (inner.val.method != "cv") rv$cross.inner =NULL
# }
rv <- list(classes=as.factor(y),
sample.names = names(y),
class.method=paste("svm",fs.method ),
#cross.outer=cross.outer,
grid.search=grid.search,
seed = seed,
model =model,
lambda1.set=lambda1.set,
lambda2.set=lambda2.set,
bounds=bounds,
inner.val.method = inner.val.method,
cross.inner= cross.inner )
if (inner.val.method != "cv") rv$cross.inner =NULL
#class(rv) <- "MCRestimate"
class(rv) <- "penSVM"
return(rv)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.