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

automation

parent d0084154
......@@ -67,14 +67,16 @@
#' y <- rnorm(n)
#' X <- matrix(rnorm(n*p),nrow=n,ncol=p)
#' net <- cornet(y=y,cutoff=0,X=X)
#'
#' ### 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",...){
#--- temporary ---
# cutoff <- 0; npi <- 101; pi <- NULL; nsigma <- 99; sigma <- NULL; nfolds <- 10; foldid <- NULL; type.measure <- "deviance"; logistic <- TRUE
test <- list()
test$sigma <- test$pi <- FALSE
test$grid <- TRUE
test$combined <- TRUE
#--- checks ---
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
if(test$pi){
pred$pi <- matrix(data=NA,nrow=n,ncol=npi)
}
if(test$grid){
if(test$combined){
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)){
......@@ -183,12 +185,12 @@ cornet <- function(y,cutoff,X,alpha=1,npi=101,pi=NULL,nsigma=99,sigma=NULL,nfold
}
}
# fusion (grid)
if(test$grid){
# fusion (combined)
if(test$combined){
for(i in seq_along(fit$sigma)){
for(j in seq_along(fit$pi)){
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
#fit$pi.min1 <- fit$pi[which.min(fit$pi.cvm)]
}
if(test$grid){
if(test$combined){
dimnames <- list(lab.sigma,lab.pi)
fit$cvm <- matrix(data=NA,nrow=nsigma,ncol=npi,dimnames=dimnames)
for(i in seq_len(nsigma)){
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)
......@@ -404,9 +406,9 @@ predict.cornet <- function(object,newx,type="probability",...){
#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)
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
......@@ -434,7 +436,13 @@ predict.cornet <- function(object,newx,type="probability",...){
#' Comparison
#'
#' @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
#'
......@@ -484,6 +492,18 @@ predict.cornet <- function(object,newx,type="probability",...){
# residual increase/decrease
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
loss$resid.pvalue <- numeric()
for(i in seq_len(nfolds)){
......@@ -496,13 +516,18 @@ predict.cornet <- function(object,newx,type="probability",...){
}
#' @export
#' @title
#' Testing
#' Single-split test
#'
#' @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
#'
......@@ -528,7 +553,6 @@ predict.cornet <- function(object,newx,type="probability",...){
pred[pred < limit] <- limit
pred[pred > 1 - limit] <- 1 - limit
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
return(pvalue)
......
......@@ -15,6 +15,10 @@ cache:
# Adapt as necessary starting from here
environment:
global:
USE_RTOOLS: true
build_script:
- travis-tool.sh install_bioc_deps
- travis-tool.sh install_deps
......
......@@ -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'>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='co'>### Add ... to all glmnet::glmnet calls !!! ###</span></div></pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="sidebar">
......
......@@ -32,7 +32,7 @@
<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" />
......@@ -107,7 +107,7 @@
<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>
......@@ -155,6 +155,13 @@ or <code>NULL</code> (balance)</p></td>
</tr>
</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>
<pre class="examples"><div class='input'><span class='fl'>NA</span></div><div class='output co'>#&gt; [1] NA</div><div class='input'>
......@@ -165,6 +172,8 @@ or <code>NULL</code> (balance)</p></td>
<ul class="nav nav-pills nav-stacked">
<li><a href="#arguments">Arguments</a></li>
<li><a href="#details">Details</a></li>
<li><a href="#examples">Examples</a></li>
</ul>
......
......@@ -6,7 +6,7 @@
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Testing — .test • cornet</title>
<title>Single-split test — .test • cornet</title>
<!-- jquery -->
<script src="https://code.jquery.com/jquery-3.1.0.min.js" integrity="sha384-nrOSfDHtoPMzJHjVTdCopGqIqeYETSXhZDFyniQ8ZHcVy08QesyHcnOUpMpqnmWq" crossorigin="anonymous"></script>
......@@ -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" />
......@@ -100,14 +100,14 @@
<div class="row">
<div class="col-md-9 contents">
<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>
<div class="hidden name"><code>dot-test.Rd</code></div>
</div>
<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>
......@@ -144,6 +144,13 @@ numeric between \(0\) (ridge) and \(1\) (lasso)</p></td>
</tr>
</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>
<pre class="examples"><div class='input'><span class='fl'>NA</span></div><div class='output co'>#&gt; [1] NA</div><div class='input'>
......@@ -154,6 +161,8 @@ numeric between \(0\) (ridge) and \(1\) (lasso)</p></td>
<ul class="nav nav-pills nav-stacked">
<li><a href="#arguments">Arguments</a></li>
<li><a href="#details">Details</a></li>
<li><a href="#examples">Examples</a></li>
</ul>
......
......@@ -150,7 +150,7 @@
<td>
<p><code><a href="dot-test.html">.test()</a></code> </p>
</td>
<td><p>Testing</p></td>
<td><p>Single-split test</p></td>
</tr><tr>
<td>
......
......@@ -59,5 +59,7 @@ n <- 100; p <- 200
y <- rnorm(n)
X <- matrix(rnorm(n*p),nrow=n,ncol=p)
net <- cornet(y=y,cutoff=0,X=X)
### Add ... to all glmnet::glmnet calls !!! ###
}
......@@ -31,7 +31,13 @@ or \code{NULL} (balance)}
(linear regression uses the deviance)}
}
\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{
NA
......
......@@ -2,7 +2,7 @@
% Please edit documentation in R/functions.R
\name{.test}
\alias{.test}
\title{Testing}
\title{Single-split test}
\usage{
.test(y, cutoff, X, alpha = 1, type.measure = "deviance")
}
......@@ -24,7 +24,13 @@ numeric between \eqn{0} (ridge) and \eqn{1} (lasso)}
(linear regression uses the deviance)}
}
\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{
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