automation

R/functions.R

@@ -169,7 +169,7 @@ starnet <- function(y,X,family="gaussian",nalpha=21,alpha=NULL,nfolds=10,foldid=
                           s=base[[i]]$glmnet.fit$lambda)
       link[[i]][foldid==k,seq_len(ncol(temp))] <- temp
     }
-  }
+  } 
   
   #--- tune base lambdas ---
   for(i in seq_len(nalpha)){
@@ -393,6 +393,8 @@ coef.starnet <- function(object,nzero=NULL,...){
                  foldid=object$info$foldid,nzero=nzero)
      coef <- stats::coef(model,s="lambda.min")
      return(list(alpha=coef[1],beta=coef[-1]))
+     # alternatives: lasso-like elastic net (alpha=0.95);
+     # logistic regression of predicted probabilities on X
   }
   
   return(pool)
@@ -479,7 +481,7 @@ print.starnet <- function(x,...){
 #' vector of length \eqn{n} with entries between \eqn{1} and \code{nfolds},
 #' or \code{NULL},
 #' for hold-out (single split) instead of cross-validation (multiple splits)\strong{:}
-#' set to \eqn{0} for training and to \eqn{1} for testing samples
+#' set \code{foldid.ext} to \eqn{0} for training and to \eqn{1} for testing samples
 #' 
 #' @param ...
 #' further arguments (not applicable)
@@ -645,7 +647,8 @@ cv.starnet <- function(y,X,family="gaussian",nalpha=21,alpha=NULL,nfolds.ext=10,
   sigma <- matrix(data=0.1,nrow=p,ncol=p)
   diag(sigma) <- 1
   X <- mvtnorm::rmvnorm(n=n,mean=mean,sigma=sigma)
-  q <- switch(mode,sparse=5,dense=50,mixed=15,stop("Invalid.",.call=FALSE))
+  q <- switch(mode,sparse=5,dense=50,mixed=20,stop("Invalid.",.call=FALSE))
+  # mixed: 15 is too lasso-friendly
   beta <- sample(rep(c(0,1),times=c(p-q,q)))
   eta <- as.numeric(X %*% beta)
   y <- eta + stats::rnorm(n=n,sd=0.5*stats::sd(eta))
@@ -689,7 +692,7 @@ cv.starnet <- function(y,X,family="gaussian",nalpha=21,alpha=NULL,nfolds.ext=10,
 #' 
 .loss <- function(y,x,family,type.measure,foldid=NULL,grouped=TRUE){
   
-  if(family=="cox" & grouped){stop("Implement \"grouped Cox\"!",call.=FALSE)}
+  if(family=="cox" & grouped){stop("Implement \"grouped Cox\"! See unit tests.",call.=FALSE)}
   
   if(is.null(foldid)&(family=="cox"|type.measure=="auc")){
     stop("Missing foldid.",call.=FALSE)
@@ -726,7 +729,7 @@ cv.starnet <- function(y,X,family="gaussian",nalpha=21,alpha=NULL,nfolds.ext=10,
       cvraw <- numeric()
       for(i in seq_along(unique(foldid))){
         if(grouped){
-          warning("Invalid \"grouped Cox\"!",call.=FALSE)
+          stop("Invalid \"grouped Cox\"! See unit tests!",call.=FALSE)
           full <- glmnet::coxnet.deviance(pred=x,y=y)
           mink <- glmnet::coxnet.deviance(pred=x[foldid!=i],y=y[foldid!=i])
           cvraw[i] <- full-mink

_pkgdown.yml

@@ -20,6 +20,8 @@ navbar:
       href: articles/starnet.html
     - text: "article"
       href: articles/article.html
+    - text: "script"
+      href: articles/script.html
     - text: "news"
       href: news/index.html
   right:

docs/404.html

@@ -82,6 +82,9 @@
 <li>
   <a href="articles/article.html">article</a>
 </li>
+<li>
+  <a href="articles/script.html">script</a>
+</li>
 <li>
   <a href="news/index.html">news</a>
 </li>

docs/articles/article.html

@@ -46,6 +46,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/articles/index.html

@@ -82,6 +82,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>
@@ -121,6 +124,7 @@
 
       <ul>
         <li><a href="article.html">Stacked Elastic Net</a></li>
+        <li><a href="script.html">Stacked Elastic Net</a></li>
         <li><a href="starnet.html">Stacked Elastic Net</a></li>
       </ul>
     </div>

docs/articles/starnet.html

@@ -46,6 +46,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/authors.html

@@ -82,6 +82,9 @@
 <li>
   <a href="articles/article.html">article</a>
 </li>
+<li>
+  <a href="articles/script.html">script</a>
+</li>
 <li>
   <a href="news/index.html">news</a>
 </li>

docs/index.html

@@ -46,6 +46,9 @@
 <li>
   <a href="articles/article.html">article</a>
 </li>
+<li>
+  <a href="articles/script.html">script</a>
+</li>
 <li>
   <a href="news/index.html">news</a>
 </li>

docs/news/index.html

@@ -82,6 +82,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/pkgdown.yml

@@ -3,5 +3,6 @@ pkgdown: 1.4.1
 pkgdown_sha: ~
 articles:
   article: article.html
+  script: script.html
   starnet: starnet.html
 

docs/reference/coef.starnet.html

@@ -85,6 +85,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/cv.starnet.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>
@@ -166,7 +169,7 @@ fold identifiers (<code>foldid</code>)<strong>:</strong>
 vector of length \(n\) with entries between \(1\) and <code>nfolds</code>,
 or <code>NULL</code>,
 for hold-out (single split) instead of cross-validation (multiple splits)<strong>:</strong>
-set to \(0\) for training and to \(1\) for testing samples</p></td>
+set <code>foldid.ext</code> to \(0\) for training and to \(1\) for testing samples</p></td>
     </tr>
     <tr>
       <th>type.measure</th>

docs/reference/dot-cv.glmnet.html

@@ -85,6 +85,9 @@ with different handling of sparsity constraints." />
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/dot-loss.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/dot-simulate.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/glmnet.auc.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/index.html

@@ -82,6 +82,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/predict.starnet.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/print.starnet.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/starnet-package.html

@@ -87,6 +87,9 @@ we combine multiple alphas by stacked generalisation." />
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/starnet.html

@@ -84,6 +84,9 @@
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

docs/reference/weights.starnet.html

@@ -85,6 +85,9 @@ i.e. the weights for the base learners." />
 <li>
   <a href="../articles/article.html">article</a>
 </li>
+<li>
+  <a href="../articles/script.html">script</a>
+</li>
 <li>
   <a href="../news/index.html">news</a>
 </li>

man/cv.starnet.Rd

@@ -33,7 +33,7 @@ fold identifiers (\code{foldid})\strong{:}
 vector of length \eqn{n} with entries between \eqn{1} and \code{nfolds},
 or \code{NULL},
 for hold-out (single split) instead of cross-validation (multiple splits)\strong{:}
-set to \eqn{0} for training and to \eqn{1} for testing samples}
+set \code{foldid.ext} to \eqn{0} for training and to \eqn{1} for testing samples}
 
 \item{type.measure}{loss function\strong{:}
 character "deviance", "class", "mse" or "mae"

tests/testthat/test.R

@@ -108,7 +108,7 @@ for(family in c("gaussian","binomial")){
 #--- testing the loss function ---
 
 set.seed(1)
-for(family in c("gaussian","binomial","poisson","cox","mgaussian","multinomial")){
+for(family in c("gaussian","binomial","poisson","mgaussian","multinomial","cox")){
   for(type.measure in c("deviance","mse","mae","class","auc")){
     
     if(type.measure=="class" & !family %in% c("binomial","multinomial")){next}
@@ -208,13 +208,19 @@ if(FALSE){
   all(abs(old-new)<1e-06)
   
   ### Cox: averaging
-  cvraw <- old # choose one "old" or "new" from above
+   # choose one from above
   # old
+  cvraw <- old
   status = y[, "status"]
   weights = as.vector(tapply(status, foldid, sum))
   temp = as.matrix(cvraw/weights,ncol=1)
   apply(temp, 2, weighted.mean, w = weights, na.rm = TRUE)
   # new
+  cvraw <- new
   weights <- tapply(X = y[, "status"], INDEX = foldid, FUN = sum)
   stats::weighted.mean(x = cvraw/weights, w = weights, na.rm = TRUE)
+  
+  grouped <- TRUE # FALSE or TRUE
+  glmnet::cv.glmnet(y=y,x=X,alpha=alpha,lambda=c(lambda,0.5*lambda),foldid=foldid,family="cox",grouped=grouped)$cvm[1]
+  
 }