Commit 00042322 authored by Armin Rauschenberger's avatar Armin Rauschenberger
Browse files

automation

parent d0084154
...@@ -67,14 +67,16 @@ ...@@ -67,14 +67,16 @@
#' y <- rnorm(n) #' y <- rnorm(n)
#' X <- matrix(rnorm(n*p),nrow=n,ncol=p) #' X <- matrix(rnorm(n*p),nrow=n,ncol=p)
#' net <- cornet(y=y,cutoff=0,X=X) #' net <- cornet(y=y,cutoff=0,X=X)
#'
#' ### Add ... to all glmnet::glmnet calls !!! ### #' ### Add ... to all glmnet::glmnet calls !!! ###
#'
cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfolds=10,foldid=NULL,type.measure="deviance",...){ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfolds=10,foldid=NULL,type.measure="deviance",...){
#--- temporary --- #--- temporary ---
# cutoff <- 0; npi <- 101; pi <- NULL; nsigma <- 99; sigma <- NULL; nfolds <- 10; foldid <- NULL; type.measure <- "deviance"; logistic <- TRUE # cutoff <- 0; npi <- 101; pi <- NULL; nsigma <- 99; sigma <- NULL; nfolds <- 10; foldid <- NULL; type.measure <- "deviance"; logistic <- TRUE
test <- list() test <- list()
test$sigma <- test$pi <- FALSE test$sigma <- test$pi <- FALSE
test$grid <- TRUE test$combined <- TRUE
#--- checks --- #--- checks ---
cornet:::.check(x=y,type="vector") cornet:::.check(x=y,type="vector")
...@@ -140,9 +142,9 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold ...@@ -140,9 +142,9 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold
if(test$pi){ if(test$pi){
pred$pi <- matrix(data=NA,nrow=n,ncol=npi) pred$pi <- matrix(data=NA,nrow=n,ncol=npi)
} }
if(test$grid){ if(test$combined){
dimnames <- list(NULL,lab.sigma,lab.pi) dimnames <- list(NULL,lab.sigma,lab.pi)
pred$grid <- array(data=NA,dim=c(n,nsigma,npi),dimnames=dimnames) pred$combined <- array(data=NA,dim=c(n,nsigma,npi),dimnames=dimnames)
} }
for(k in seq_len(nfolds)){ for(k in seq_len(nfolds)){
...@@ -183,12 +185,12 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold ...@@ -183,12 +185,12 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold
} }
} }
# fusion (grid) # fusion (combined)
if(test$grid){ if(test$combined){
for(i in seq_along(fit$sigma)){ for(i in seq_along(fit$sigma)){
for(j in seq_along(fit$pi)){ for(j in seq_along(fit$pi)){
cont <- stats::pnorm(q=y_hat,mean=cutoff,sd=fit$sigma[i]) cont <- stats::pnorm(q=y_hat,mean=cutoff,sd=fit$sigma[i])
pred$grid[foldid==k,i,j] <- fit$pi[j]*cont + (1-fit$pi[j])*z_hat pred$combined[foldid==k,i,j] <- fit$pi[j]*cont + (1-fit$pi[j])*z_hat
} }
} }
} }
...@@ -213,12 +215,12 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold ...@@ -213,12 +215,12 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold
#fit$pi.min1 <- fit$pi[which.min(fit$pi.cvm)] #fit$pi.min1 <- fit$pi[which.min(fit$pi.cvm)]
} }
if(test$grid){ if(test$combined){
dimnames <- list(lab.sigma,lab.pi) dimnames <- list(lab.sigma,lab.pi)
fit$cvm <- matrix(data=NA,nrow=nsigma,ncol=npi,dimnames=dimnames) fit$cvm <- matrix(data=NA,nrow=nsigma,ncol=npi,dimnames=dimnames)
for(i in seq_len(nsigma)){ for(i in seq_len(nsigma)){
for(j in seq_len(npi)){ for(j in seq_len(npi)){
fit$cvm[i,j] <- cornet:::.loss(y=z,fit=pred$grid[,i,j],family="binomial",type.measure=type.measure)[[1]] fit$cvm[i,j] <- cornet:::.loss(y=z,fit=pred$combined[,i,j],family="binomial",type.measure=type.measure)[[1]]
} }
} }
temp <- which(fit$cvm==min(fit$cvm),arr.ind=TRUE,useNames=TRUE) temp <- which(fit$cvm==min(fit$cvm),arr.ind=TRUE,useNames=TRUE)
...@@ -404,9 +406,9 @@ predict.cornet <- function(object,newx,type="probability",...){ ...@@ -404,9 +406,9 @@ predict.cornet <- function(object,newx,type="probability",...){
#prob$pi <- x$pi.min*prob$gaussian + (1-x$pi.min)*prob$binomial #prob$pi <- x$pi.min*prob$gaussian + (1-x$pi.min)*prob$binomial
} }
if(test$grid){ if(test$combined){
cont <- stats::pnorm(q=link,mean=x$cutoff,sd=x$sigma.min) cont <- stats::pnorm(q=link,mean=x$cutoff,sd=x$sigma.min)
prob$grid <- x$pi.min*cont + (1-x$pi.min)*prob$binomial prob$combined <- x$pi.min*cont + (1-x$pi.min)*prob$binomial
} }
# consistency tests # consistency tests
...@@ -434,8 +436,14 @@ predict.cornet <- function(object,newx,type="probability",...){ ...@@ -434,8 +436,14 @@ predict.cornet <- function(object,newx,type="probability",...){
#' Comparison #' Comparison
#' #'
#' @description #' @description
#' Compares models for a continuous response with a cutoff value #' Compares models for a continuous response with a cutoff value.
#' #'
#' @details
#' Uses k-fold cross-validation,
#' fits linear, logistic, and combined regression,
#' calculates different loss functions,
#' and examines squared deviance residuals.
#'
#' @inheritParams cornet #' @inheritParams cornet
#' #'
#' @examples #' @examples
...@@ -484,6 +492,18 @@ predict.cornet <- function(object,newx,type="probability",...){ ...@@ -484,6 +492,18 @@ predict.cornet <- function(object,newx,type="probability",...){
# residual increase/decrease # residual increase/decrease
loss$resid.factor <- stats::median((rys-rxs)/rxs) loss$resid.factor <- stats::median((rys-rxs)/rxs)
if(FALSE){# tests
# equality deviance
loss$deviance["binomial"]==mean(res[,"binomial"])
loss$deviance["combined"]==mean(res[,"combined"])
# percentage decrease
#range((rys-rxs)/rxs)
stats::median((rys-rxs)/rxs)
mean((rys-rxs)/rxs)
(sum(rys)-sum(rxs))/sum(rxs)
(loss$deviance["combined"]-loss$deviance["binomial"])/loss$deviance["binomial"]
}
# paired test for each fold # paired test for each fold
loss$resid.pvalue <- numeric() loss$resid.pvalue <- numeric()
for(i in seq_len(nfolds)){ for(i in seq_len(nfolds)){
...@@ -496,14 +516,19 @@ predict.cornet <- function(object,newx,type="probability",...){ ...@@ -496,14 +516,19 @@ predict.cornet <- function(object,newx,type="probability",...){
} }
#' @export #' @export
#' @title #' @title
#' Testing #' Single-split test
#' #'
#' @description #' @description
#' Compares models for a continuous response with a cutoff value (testing) #' Compares models for a continuous response with a cutoff value.
#' #'
#' @details
#' Splits samples into 80% for training and 20% for testing,
#' calculates squared deviance residuals of logistic and combined regression,
#' conducts the paired one-sided Wilcoxon signed rank test,
#' and returns the p-value.
#'
#' @inheritParams cornet #' @inheritParams cornet
#' #'
#' @examples #' @examples
...@@ -528,7 +553,6 @@ predict.cornet <- function(object,newx,type="probability",...){ ...@@ -528,7 +553,6 @@ predict.cornet <- function(object,newx,type="probability",...){
pred[pred < limit] <- limit pred[pred < limit] <- limit
pred[pred > 1 - limit] <- 1 - limit pred[pred > 1 - limit] <- 1 - limit
res <- -2 * (z[fold==1] * log(pred) + (1 - z[fold==1]) * log(1 - pred)) res <- -2 * (z[fold==1] * log(pred) + (1 - z[fold==1]) * log(1 - pred))
# Changed y to z (2019-02-08)
pvalue <- stats::wilcox.test(x=res[,"binomial"],y=res[,"combined"],paired=TRUE,alternative="greater")$p.value pvalue <- stats::wilcox.test(x=res[,"binomial"],y=res[,"combined"],paired=TRUE,alternative="greater")$p.value
return(pvalue) return(pvalue)
......
...@@ -15,6 +15,10 @@ cache: ...@@ -15,6 +15,10 @@ cache:
# Adapt as necessary starting from here # Adapt as necessary starting from here
environment:
global:
USE_RTOOLS: true
build_script: build_script:
- travis-tool.sh install_bioc_deps - travis-tool.sh install_bioc_deps
- travis-tool.sh install_deps - travis-tool.sh install_deps
......
...@@ -193,6 +193,7 @@ numeric between \(0\) (ridge) and \(1\) (lasso) ...@@ -193,6 +193,7 @@ numeric between \(0\) (ridge) and \(1\) (lasso)
<span class='no'>y</span> <span class='kw'>&lt;-</span> <span class='fu'>rnorm</span>(<span class='no'>n</span>) <span class='no'>y</span> <span class='kw'>&lt;-</span> <span class='fu'>rnorm</span>(<span class='no'>n</span>)
<span class='no'>X</span> <span class='kw'>&lt;-</span> <span class='fu'>matrix</span>(<span class='fu'>rnorm</span>(<span class='no'>n</span>*<span class='no'>p</span>),<span class='kw'>nrow</span><span class='kw'>=</span><span class='no'>n</span>,<span class='kw'>ncol</span><span class='kw'>=</span><span class='no'>p</span>) <span class='no'>X</span> <span class='kw'>&lt;-</span> <span class='fu'>matrix</span>(<span class='fu'>rnorm</span>(<span class='no'>n</span>*<span class='no'>p</span>),<span class='kw'>nrow</span><span class='kw'>=</span><span class='no'>n</span>,<span class='kw'>ncol</span><span class='kw'>=</span><span class='no'>p</span>)
<span class='no'>net</span> <span class='kw'>&lt;-</span> <span class='fu'>cornet</span>(<span class='kw'>y</span><span class='kw'>=</span><span class='no'>y</span>,<span class='kw'>cutoff</span><span class='kw'>=</span><span class='fl'>0</span>,<span class='kw'>X</span><span class='kw'>=</span><span class='no'>X</span>) <span class='no'>net</span> <span class='kw'>&lt;-</span> <span class='fu'>cornet</span>(<span class='kw'>y</span><span class='kw'>=</span><span class='no'>y</span>,<span class='kw'>cutoff</span><span class='kw'>=</span><span class='fl'>0</span>,<span class='kw'>X</span><span class='kw'>=</span><span class='no'>X</span>)
<span class='co'>### Add ... to all glmnet::glmnet calls !!! ###</span></div></pre> <span class='co'>### Add ... to all glmnet::glmnet calls !!! ###</span></div></pre>
</div> </div>
<div class="col-md-3 hidden-xs hidden-sm" id="sidebar"> <div class="col-md-3 hidden-xs hidden-sm" id="sidebar">
......
...@@ -32,7 +32,7 @@ ...@@ -32,7 +32,7 @@
<meta property="og:title" content="Comparison — .compare" /> <meta property="og:title" content="Comparison — .compare" />
<meta property="og:description" content="Compares models for a continuous response with a cutoff value" /> <meta property="og:description" content="Compares models for a continuous response with a cutoff value." />
<meta name="twitter:card" content="summary" /> <meta name="twitter:card" content="summary" />
...@@ -107,7 +107,7 @@ ...@@ -107,7 +107,7 @@
<div class="ref-description"> <div class="ref-description">
<p>Compares models for a continuous response with a cutoff value</p> <p>Compares models for a continuous response with a cutoff value.</p>
</div> </div>
...@@ -155,6 +155,13 @@ or <code>NULL</code> (balance)</p></td> ...@@ -155,6 +155,13 @@ or <code>NULL</code> (balance)</p></td>
</tr> </tr>
</table> </table>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p>Uses k-fold cross-validation,
fits linear, logistic, and combined regression,
calculates different loss functions,
and examines squared deviance residuals.</p>
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2> <h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><div class='input'><span class='fl'>NA</span></div><div class='output co'>#&gt; [1] NA</div><div class='input'> <pre class="examples"><div class='input'><span class='fl'>NA</span></div><div class='output co'>#&gt; [1] NA</div><div class='input'>
...@@ -164,7 +171,9 @@ or <code>NULL</code> (balance)</p></td> ...@@ -164,7 +171,9 @@ or <code>NULL</code> (balance)</p></td>
<h2>Contents</h2> <h2>Contents</h2>
<ul class="nav nav-pills nav-stacked"> <ul class="nav nav-pills nav-stacked">
<li><a href="#arguments">Arguments</a></li> <li><a href="#arguments">Arguments</a></li>
<li><a href="#details">Details</a></li>
<li><a href="#examples">Examples</a></li> <li><a href="#examples">Examples</a></li>
</ul> </ul>
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
<meta http-equiv="X-UA-Compatible" content="IE=edge"> <meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0"> <meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Testing — .test • cornet</title> <title>Single-split test — .test • cornet</title>
<!-- jquery --> <!-- jquery -->
<script src="https://code.jquery.com/jquery-3.1.0.min.js" integrity="sha384-nrOSfDHtoPMzJHjVTdCopGqIqeYETSXhZDFyniQ8ZHcVy08QesyHcnOUpMpqnmWq" crossorigin="anonymous"></script> <script src="https://code.jquery.com/jquery-3.1.0.min.js" integrity="sha384-nrOSfDHtoPMzJHjVTdCopGqIqeYETSXhZDFyniQ8ZHcVy08QesyHcnOUpMpqnmWq" crossorigin="anonymous"></script>
...@@ -30,9 +30,9 @@ ...@@ -30,9 +30,9 @@
<meta property="og:title" content="Testing — .test" /> <meta property="og:title" content="Single-split test — .test" />
<meta property="og:description" content="Compares models for a continuous response with a cutoff value (testing)" /> <meta property="og:description" content="Compares models for a continuous response with a cutoff value." />
<meta name="twitter:card" content="summary" /> <meta name="twitter:card" content="summary" />
...@@ -100,14 +100,14 @@ ...@@ -100,14 +100,14 @@
<div class="row"> <div class="row">
<div class="col-md-9 contents"> <div class="col-md-9 contents">
<div class="page-header"> <div class="page-header">
<h1>Testing</h1> <h1>Single-split test</h1>
<small class="dont-index">Source: <a href='https://github.com/rauschenberger/colasso/blob/master/R/functions.R'><code>R/functions.R</code></a></small> <small class="dont-index">Source: <a href='https://github.com/rauschenberger/colasso/blob/master/R/functions.R'><code>R/functions.R</code></a></small>
<div class="hidden name"><code>dot-test.Rd</code></div> <div class="hidden name"><code>dot-test.Rd</code></div>
</div> </div>
<div class="ref-description"> <div class="ref-description">
<p>Compares models for a continuous response with a cutoff value (testing)</p> <p>Compares models for a continuous response with a cutoff value.</p>
</div> </div>
...@@ -144,6 +144,13 @@ numeric between \(0\) (ridge) and \(1\) (lasso)</p></td> ...@@ -144,6 +144,13 @@ numeric between \(0\) (ridge) and \(1\) (lasso)</p></td>
</tr> </tr>
</table> </table>
<h2 class="hasAnchor" id="details"><a class="anchor" href="#details"></a>Details</h2>
<p>Splits samples into 80<!-- % for training and 20% for testing, -->
calculates squared deviance residuals of logistic and combined regression,
conducts the paired one-sided Wilcoxon signed rank test,
and returns the p-value.</p>
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2> <h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><div class='input'><span class='fl'>NA</span></div><div class='output co'>#&gt; [1] NA</div><div class='input'> <pre class="examples"><div class='input'><span class='fl'>NA</span></div><div class='output co'>#&gt; [1] NA</div><div class='input'>
...@@ -153,7 +160,9 @@ numeric between \(0\) (ridge) and \(1\) (lasso)</p></td> ...@@ -153,7 +160,9 @@ numeric between \(0\) (ridge) and \(1\) (lasso)</p></td>
<h2>Contents</h2> <h2>Contents</h2>
<ul class="nav nav-pills nav-stacked"> <ul class="nav nav-pills nav-stacked">
<li><a href="#arguments">Arguments</a></li> <li><a href="#arguments">Arguments</a></li>
<li><a href="#details">Details</a></li>
<li><a href="#examples">Examples</a></li> <li><a href="#examples">Examples</a></li>
</ul> </ul>
......
...@@ -150,7 +150,7 @@ ...@@ -150,7 +150,7 @@
<td> <td>
<p><code><a href="dot-test.html">.test()</a></code> </p> <p><code><a href="dot-test.html">.test()</a></code> </p>
</td> </td>
<td><p>Testing</p></td> <td><p>Single-split test</p></td>
</tr><tr> </tr><tr>
<td> <td>
......
...@@ -59,5 +59,7 @@ n <- 100; p <- 200 ...@@ -59,5 +59,7 @@ n <- 100; p <- 200
y <- rnorm(n) y <- rnorm(n)
X <- matrix(rnorm(n*p),nrow=n,ncol=p) X <- matrix(rnorm(n*p),nrow=n,ncol=p)
net <- cornet(y=y,cutoff=0,X=X) net <- cornet(y=y,cutoff=0,X=X)
### Add ... to all glmnet::glmnet calls !!! ### ### Add ... to all glmnet::glmnet calls !!! ###
} }
...@@ -31,7 +31,13 @@ or \code{NULL} (balance)} ...@@ -31,7 +31,13 @@ or \code{NULL} (balance)}
(linear regression uses the deviance)} (linear regression uses the deviance)}
} }
\description{ \description{
Compares models for a continuous response with a cutoff value Compares models for a continuous response with a cutoff value.
}
\details{
Uses k-fold cross-validation,
fits linear, logistic, and combined regression,
calculates different loss functions,
and examines squared deviance residuals.
} }
\examples{ \examples{
NA NA
......
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
% Please edit documentation in R/functions.R % Please edit documentation in R/functions.R
\name{.test} \name{.test}
\alias{.test} \alias{.test}
\title{Testing} \title{Single-split test}
\usage{ \usage{
.test(y, cutoff, X, alpha = 1, type.measure = "deviance") .test(y, cutoff, X, alpha = 1, type.measure = "deviance")
} }
...@@ -24,7 +24,13 @@ numeric between \eqn{0} (ridge) and \eqn{1} (lasso)} ...@@ -24,7 +24,13 @@ numeric between \eqn{0} (ridge) and \eqn{1} (lasso)}
(linear regression uses the deviance)} (linear regression uses the deviance)}
} }
\description{ \description{
Compares models for a continuous response with a cutoff value (testing) Compares models for a continuous response with a cutoff value.
}
\details{
Splits samples into 80% for training and 20% for testing,
calculates squared deviance residuals of logistic and combined regression,
conducts the paired one-sided Wilcoxon signed rank test,
and returns the p-value.
} }
\examples{ \examples{
NA NA
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment