[Mboost-commits] r843 - in pkg/mboostDevel: . R

[noreply at r-forge.r-project.org]

Author: hofner
Date: 2015-04-02 11:41:44 +0200 (Thu, 02 Apr 2015)
New Revision: 843

Removed:
   pkg/mboostDevel/R/bkernel.R
Modified:
   pkg/mboostDevel/NAMESPACE
   pkg/mboostDevel/R/helpers.R
Log:
removed experimental features

Modified: pkg/mboostDevel/NAMESPACE
===================================================================
--- pkg/mboostDevel/NAMESPACE	2015-04-02 09:20:44 UTC (rev 842)
+++ pkg/mboostDevel/NAMESPACE	2015-04-02 09:41:44 UTC (rev 843)
@@ -21,7 +21,7 @@
        ExpectReg, NBinomial, PropOdds, Weibull, Loglog, Lognormal, AUC, mboost_fit,
        Huber, AdaExp, Gehan, CoxPH, Hurdle, Multinomial, FP, IPCweights,
        cvrisk, cv, bbs,
-       bols, bspatial, brandom, btree, bss, bns, brad, bmono, bmrf, buser, bkernel,
+       bols, bspatial, brandom, btree, bss, bns, brad, bmono, bmrf, buser,
        survFit, selected, selected.mboost,
        nuisance, "%+%", "%X%", "%O%", extract, risk, "mstop<-",
        stabsel.mboost, stabsel_parameters.mboost, confint.mboost, confint.glmboost,

Deleted: pkg/mboostDevel/R/bkernel.R
===================================================================
--- pkg/mboostDevel/R/bkernel.R	2015-04-02 09:20:44 UTC (rev 842)
+++ pkg/mboostDevel/R/bkernel.R	2015-04-02 09:41:44 UTC (rev 843)
@@ -1,74 +0,0 @@
-bkernel <- function(..., df = 4, lambda = NULL, kernel = kernel.lin,
-                    pathway = NULL, args = list()) {
-
-    cll <- match.call()
-    cll[[1]] <- as.name("bkernel")
-
-    mf <- list(...)
-    if (length(mf) > 1 || !inherits(mf[[1]], "databel"))
-        stop(sQuote("..."), " must be a single object of class ",
-             sQuote("databel"))
-
-    mf <- mf[[1]]
-    if (is.null(attr(mf, "anno")))
-        stop("SNP data needs annotation as ",
-             sQuote('attr(, "anno")'))
-
-    ### all data checks should be done in kangar00!
-
-    ret <- list(model.frame = function() mf,
-                get_call = function(){
-                    cll <- deparse(cll, width.cutoff=500L)
-                    if (length(cll) > 1)
-                        cll <- paste(cll, collapse="")
-                    cll
-                },
-                get_data = function() mf,
-                get_index = function() NULL,
-                get_vary = function() "",
-### <FIXME> Do we really want these colnames or simply the name of ...?
-                get_names = function() colnames(mf at geno),
-                set_names = function(value) {
-                    if(length(value) != length(colnames(mf at geno)))
-                        stop(sQuote("value"), " must have same length as ",
-                             sQuote("colnames(mf)"))
-                    for (i in 1:length(value)){
-                        cll[[i+1]] <<- as.name(value[i])
-                    }
-                    attr(mf at geno, "names") <<- value
-                })
-## </FIXME>@geno
-    class(ret) <- "blg"
-
-    ret$dpp <- bl_lin(ret, Xfun = X_kernel,
-                      args = hyper_kernel(df = df, lambda = lambda,
-                                          kernel = kernel, pathway = pathway,
-                                          args = args))
-    return(ret)
-}
-
-
-### model.matrix for kriging base-learners
-X_kernel <- function(mf, vary, args) {
-
-    ## add GWASdata to args (in order to use do.call)
-    args$args$data <- mf
-    ## compute kernel with arguments args$args
-    X <- K <- do.call(args$kernel, args$args)@kernel
-
-    e <- eigen(X)
-
-    PEN_sqrt_INV <- solve(e$vectors %*% diag(sqrt(e$values)) %*% t(e$vectors))
-    X <- X %*% PEN_sqrt_INV
-    K <- diag(ncol(X))
-    return(list(X = X, K = K))
-}
-
-### hyper parameters for kernel base-learners
-hyper_kernel <- function(df = 4, lambda = NULL, kernel = kernel.lin,
-                       pathway = NULL, args = list()) {
-    list(df = df, lambda = lambda, kernel = kernel, args = c(pathway = pathway, args))
-}
-
-### <FIXME> Add possibility to specify ANA'
-### <FIXME> What about newdata in bl_lin?

Modified: pkg/mboostDevel/R/helpers.R
===================================================================
--- pkg/mboostDevel/R/helpers.R	2015-04-02 09:20:44 UTC (rev 842)
+++ pkg/mboostDevel/R/helpers.R	2015-04-02 09:41:44 UTC (rev 843)
@@ -50,10 +50,6 @@
 Complete.cases <- function(x) {
     if (isMATRIX(x))
         return(rowSums(is.na(x)) == 0)
-    if (inherits(x, "databel")) {
-        warning("for databel data complete.cases are currently not checked")
-        return(rep(TRUE, nrow(x)))
-    }
     complete.cases(x)
 }