Gitlab is now using https://gitlab.lcsb.uni.lu as it's primary address. Please update your bookmarks. FAQ.

Commit 41b1c645 authored by Armin Rauschenberger's avatar Armin Rauschenberger
Browse files

automation

parent a2b2ad73
This diff is collapsed.
......@@ -3,7 +3,7 @@ Version: 0.0.0
Title: Stable Sparse Regression
Description: Implements colasso.
Depends: R (>= 3.0.0)
Imports: glmnet, MASS, weights
Imports: glmnet, MASS, weights, palasso
Suggests: knitr, testthat
Authors@R: person("Armin","Rauschenberger",email="a.rauschenberger@vumc.nl",role=c("aut","cre"))
VignetteBuilder: knitr
......
......@@ -36,39 +36,43 @@
#' see glmnet
#'
#' @examples
#' n <- 100; p <- 20
#' n <- 100; p <- 20; q <- 10
#' X <- matrix(rnorm(n*p),nrow=n,ncol=p)
#' Y <- matrix(rnorm(n*q),nrow=n,ncol=q)
#' #y <- rbinom(n=n,size=1,prob=0.2)
#' y <- rnorm(n=n)
#' #y[1] <- 0.5
#' #a <- glmnet::glmnet(y=y,x=x,family="binomial")
#' #b <- stats::glm(y~x,family="binomial")
#' test <- colasso(y=y,Y=Y,X=X)
#'
colasso <- function(y,Y,X,alpha=1,nfolds=10,family="gaussian",type.measure="deviance"){
# properties
n <- nrow(X); p <- ncol(X)
if(!family %in% c("gaussian","poisson","binomial")){
stop("Family not implemented.")
}
if(length(y)!=n){stop("sample size")}
foldid <- sample(x=rep(x=seq_len(nfolds),length.out=n))
#foldid <- sample(x=rep(x=seq_len(nfolds),length.out=n))
foldid <- palasso:::.folds(y=y,nfolds=nfolds)
# weights
pi <- seq(from=0,to=1,by=0.2) # adapt this
# model fitting
fit <- list()
ym <- colasso_moderate(Y=Y) # trial
ym <- colasso::colasso_moderate(Y=Y) # trial
for(i in seq_along(pi)){
weights <- rep(c(1-pi[[i]],pi[[i]]),each=n)
fit[[i]] <- glmnet::glmnet(y=c(y,ym),x=rbind(X,X),weights=weights,family=family,alpha=alpha)
}
names(fit) <- paste0("pi",pi)
# inner cross-validation
pred <- lapply(pi,function(x) matrix(data=NA,nrow=length(y),ncol=100))
for(k in sort(unique(foldid))){
for(k in unique(foldid)){
y0 <- y[foldid!=k]
#y1 <- y[foldid==k]
y1 <- y[foldid==k]
Y0 <- Y[foldid!=k,,drop=FALSE]
#Y1 <- Y[foldid==k,,drop=FALSE]
Y1 <- Y[foldid==k,,drop=FALSE]
X0 <- X[foldid!=k,,drop=FALSE]
X1 <- X[foldid==k,,drop=FALSE]
......@@ -81,12 +85,25 @@ colasso <- function(y,Y,X,alpha=1,nfolds=10,family="gaussian",type.measure="devi
}
}
# loss sequence
# loss sequence
for(i in seq_along(pi)){
fit[[i]]$cvm <- apply(X=pred[[i]],MARGIN=2,FUN=function(x) mean((x-y)^2))
fit[[i]]$lambda.min <- fit[[i]]$lambda[which.min(fit[[i]]$cvm)]
# WATCH OUT: adapt to all loss fuctions
#fit[[i]]$cvm <- apply(X=pred[[i]],MARGIN=2,FUN=function(x) mean((x-y)^2))
fit[[i]]$cvm <- palasso:::.loss(y=y,fit=pred[[i]],family=family,type.measure=type.measure,foldid=foldid)[[1]]
# WATCH OUT: minimise or maximise
if(type.measure=="AUC"){
fit[[i]]$lambda.min <- fit[[i]]$lambda[which.max(fit[[i]]$cvm)]
} else {
fit[[i]]$lambda.min <- fit[[i]]$lambda[which.min(fit[[i]]$cvm)]
}
}
# loss sequence
#cvm <- palasso:::.loss(y=y,fit=pred,family=family,type.measure=type.measure,foldid=foldid)
# optimisation
#model <- .extract(fit=fit.full,lambda=lambda,cvm=cvm,type.measure=args$type.measure)
# selection
cvm <- sapply(fit,function(x) x$cvm[which(x$lambda==x$lambda.min)])
if(type.measure=="AUC"){
......@@ -97,7 +114,7 @@ colasso <- function(y,Y,X,alpha=1,nfolds=10,family="gaussian",type.measure="devi
fit[[length(pi)+1]] <- fit[[sel]]
#graphics::plot(cvm); graphics::abline(v=sel,lty=2)
names(fit) <- c("standard",paste0("pi",pi[-1]),"select")
names(fit) <- c("glmnet",paste0("pi",pi[-1]),"conet")
return(fit)
}
......@@ -112,21 +129,20 @@ colasso <- function(y,Y,X,alpha=1,nfolds=10,family="gaussian",type.measure="devi
#' This function ...
#'
#' @inheritParams colasso
#'
#' @param pi
#'
#' @param ...
#' further arguments (currently not implemented)
#' vector with entries between \eqn{0} and \eqn{1} (rename argument)
#'
#' @param plot
#' logical
#'
#'
#' @examples
#' NA
colasso_moderate <- function(Y){
colasso_moderate <- function(Y,...){
# (most basic version possible)
y <- rowMeans(Y)
y <- apply(Y,1,median)
if(all(y) %in% c(0,0.5,1)){
y <- apply(Y,1,stats::median)
if(all(y %in% c(0,0.5,1))){
y[y==0.5] <- 1
warning("Invalid unless binomial family.")
}
......@@ -152,6 +168,9 @@ colasso_moderate <- function(Y){
#' @param plot
#' logical
#'
#' @param family
#' character
#'
#' @examples
#' # CONTINUE HERE
#'
......@@ -231,6 +250,8 @@ colasso_simulate <- function(n=100,p=500,cor="constant",family="gaussian",plot=T
#' @param nfolds.int
#' internal folds
#'
#' @inheritParams colasso
#'
#' @examples
#' NA
#'
......@@ -282,9 +303,14 @@ colasso_compare <- function(y,Y,X,plot=TRUE,nfolds.int=10,family="gaussian",type
graphics::par(mar=c(3,3,1,1))
col <- rep(x=0,times=length(loss)-1)
col[1] <- col[length(col)] <- 1
graphics::plot(y=loss[-length(loss)],
graphics::plot.new()
graphics::plot.window(xlim=c(1,length(loss)-1),ylim=range(loss))
graphics::axis(side=1,at=seq_len(length(loss)-1),labels=names(loss)[-length(loss)])
graphics::axis(side=2)
graphics::box()
graphics::points(y=loss[-length(loss)],
x=seq_len(length(loss)-1),
col=col+1,ylim=range(loss),pch=col)
col=col+1,pch=col)
graphics::abline(v=c(1.5,length(loss)-1.5),lty=2)
graphics::grid()
graphics::abline(h=loss[length(loss)],lty=2,col="red")
......
pandoc: 1.19.2.1
pkgdown: 1.1.0
pkgdown_sha: ~
articles: []
articles: {}
......@@ -156,13 +156,12 @@ numeric between \(0\) and \(1\);
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><div class='input'><span class='no'>n</span> <span class='kw'>&lt;-</span> <span class='fl'>100</span>; <span class='no'>p</span> <span class='kw'>&lt;-</span> <span class='fl'>20</span>
<pre class="examples"><div class='input'><span class='no'>n</span> <span class='kw'>&lt;-</span> <span class='fl'>100</span>; <span class='no'>p</span> <span class='kw'>&lt;-</span> <span class='fl'>20</span>; <span class='no'>q</span> <span class='kw'>&lt;-</span> <span class='fl'>10</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'>Y</span> <span class='kw'>&lt;-</span> <span class='fu'>matrix</span>(<span class='fu'>rnorm</span>(<span class='no'>n</span>*<span class='no'>q</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'>q</span>)
<span class='co'>#y &lt;- rbinom(n=n,size=1,prob=0.2)</span>
<span class='no'>y</span> <span class='kw'>&lt;-</span> <span class='fu'>rnorm</span>(<span class='kw'>n</span><span class='kw'>=</span><span class='no'>n</span>)
<span class='co'>#y[1] &lt;- 0.5</span>
<span class='co'>#a &lt;- glmnet::glmnet(y=y,x=x,family="binomial")</span>
<span class='co'>#b &lt;- stats::glm(y~x,family="binomial")</span></div></pre>
<span class='no'>test</span> <span class='kw'>&lt;-</span> <span class='fu'>colasso</span>(<span class='kw'>y</span><span class='kw'>=</span><span class='no'>y</span>,<span class='kw'>Y</span><span class='kw'>=</span><span class='no'>Y</span>,<span class='kw'>X</span><span class='kw'>=</span><span class='no'>X</span>)</div></pre>
</div>
<div class="col-md-3 hidden-xs hidden-sm" id="sidebar">
<h2>Contents</h2>
......
......@@ -137,6 +137,14 @@
<th>nfolds.int</th>
<td><p>internal folds</p></td>
</tr>
<tr>
<th>family</th>
<td><p>see glmnet</p></td>
</tr>
<tr>
<th>type.measure</th>
<td><p>see glmnet</p></td>
</tr>
</table>
......
......@@ -111,7 +111,7 @@
</div>
<pre class="usage"><span class='fu'>colasso_moderate</span>(<span class='no'>Y</span>)</pre>
<pre class="usage"><span class='fu'>colasso_moderate</span>(<span class='no'>Y</span>, <span class='no'>...</span>)</pre>
<h2 class="hasAnchor" id="arguments"><a class="anchor" href="#arguments"></a>Arguments</h2>
<table class="ref-arguments">
......@@ -123,12 +123,9 @@ matrix with \(n\) rows and \(p\) columns,
or vector of length \(n\) (see details)</p></td>
</tr>
<tr>
<th>pi</th>
<td><p>vector with entries between \(0\) and \(1\) (rename argument)</p></td>
</tr>
<tr>
<th>plot</th>
<td><p>logical</p></td>
<th>...</th>
<td><p>further arguments (currently not implemented)
vector with entries between \(0\) and \(1\) (rename argument)</p></td>
</tr>
</table>
......
......@@ -129,6 +129,10 @@
<th>cor</th>
<td><p>correlation structure</p></td>
</tr>
<tr>
<th>family</th>
<td><p>character</p></td>
</tr>
<tr>
<th>plot</th>
<td><p>logical</p></td>
......
......@@ -34,12 +34,11 @@ numeric between \eqn{0} and \eqn{1};
Implements penalised regression with response moderation.
}
\examples{
n <- 100; p <- 20
n <- 100; p <- 20; q <- 10
X <- matrix(rnorm(n*p),nrow=n,ncol=p)
Y <- matrix(rnorm(n*q),nrow=n,ncol=q)
#y <- rbinom(n=n,size=1,prob=0.2)
y <- rnorm(n=n)
#y[1] <- 0.5
#a <- glmnet::glmnet(y=y,x=x,family="binomial")
#b <- stats::glm(y~x,family="binomial")
test <- colasso(y=y,Y=Y,X=X)
}
......@@ -17,6 +17,10 @@ colasso_compare(y, Y, X, plot = TRUE, nfolds.int = 10,
\item{plot}{logical}
\item{nfolds.int}{internal folds}
\item{family}{see glmnet}
\item{type.measure}{see glmnet}
}
\description{
This function ...
......
......@@ -4,16 +4,15 @@
\alias{colasso_moderate}
\title{moderated response}
\usage{
colasso_moderate(Y)
colasso_moderate(Y, ...)
}
\arguments{
\item{Y}{response\strong{:}
matrix with \eqn{n} rows and \eqn{p} columns,
or vector of length \eqn{n} (see details)}
\item{pi}{vector with entries between \eqn{0} and \eqn{1} (rename argument)}
\item{plot}{logical}
\item{...}{further arguments (currently not implemented)
vector with entries between \eqn{0} and \eqn{1} (rename argument)}
}
\description{
This function ...
......
......@@ -14,6 +14,8 @@ colasso_simulate(n = 100, p = 500, cor = "constant",
\item{cor}{correlation structure}
\item{family}{character}
\item{plot}{logical}
}
\description{
......
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