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

automation

parent 461bd81d
^Readme\.Rmd$
^\.travis\.yml$
^_pkgdown\.yml$
^docs$
^cran-comments\.md$
^appveyor\.yml$
nsigma <- length(x$sigma)
npi <- length(x$pi)
sigma.min <- x$trial.min$sigma
pi.min <- x$trial.min$pi
graphics::plot.new()
graphics::par(xaxs="i",yaxs="i")
graphics::plot.window(xlim=c(1-0.5,nsigma+0.5),ylim=c(1-0.5,npi+0.5))
sel <- which(x$sigma==sigma.min)
graphics::axis(side=1,at=c(1,sel,nsigma),labels=signif(x$sigma[c(1,sel,nsigma)],digits=2))
sel <- which(x$pi==pi.min)
graphics::axis(side=2,at=c(1,sel,npi),labels=signif(x$pi[c(1,sel,npi)],digits=2))
graphics::title(xlab=expression(sigma),ylab=expression(pi))
#graphics::.filled.contour(x=seq_along(x$sigma),y=seq_along(x$pi),z=x$cvm,levels=levels,col=col)
graphics::image(x=seq_along(x$sigma),y=seq_along(x$pi),z=x$trial.cvm,breaks=levels,col=col,add=TRUE)
graphics::box()
plot.bilasso <- function(x){
k <- 100
levels <- stats::quantile(x$trial.cvm,probs=seq(from=0,to=1,length.out=k+1))
col <- colorspace::diverge_hsv(n=k)
nsigma <- length(x$sigma)
npi <- length(x$pi)
sigma.min <- x$trial.min$sigma
pi.min <- x$trial.min$pi
graphics::plot.new()
graphics::par(xaxs="i",yaxs="i")
graphics::plot.window(xlim=c(1-0.5,nsigma+0.5),ylim=c(1-0.5,npi+0.5))
sel <- which(x$sigma==sigma.min)
graphics::axis(side=1,at=c(1,sel,nsigma),labels=signif(x$sigma[c(1,sel,nsigma)],digits=2))
sel <- which(x$pi==pi.min)
graphics::axis(side=2,at=c(1,sel,npi),labels=signif(x$pi[c(1,sel,npi)],digits=2))
graphics::title(xlab=expression(sigma),ylab=expression(pi))
#graphics::.filled.contour(x=seq_along(x$sigma),y=seq_along(x$pi),z=x$cvm,levels=levels,col=col)
graphics::image(x=seq_along(x$sigma),y=seq_along(x$pi),z=x$trial.cvm,breaks=levels,col=col,add=TRUE)
graphics::box()
}
plot.bilasso(net)
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
set.seed(1)
grid <- expand.grid(prob=seq(from=0.1,to=0.2,length.out=101),
fac=seq(from=0.5,to=2,length.out=101))
grid <- grid[sample(seq_len(nrow(grid))),]
list <- list()
cat(i," ")
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
if(sd(y)==0){next}
fit <- colasso::bilasso(y=y,cutoff=0,X=X)
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
i <- 1
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
if(sd(y)==0){next}
fit <- colasso::bilasso(y=y,cutoff=0,X=X)
names(fit)
plot(fit)
library(colasso)
plot(fit)
class(fit)
plot.bilasso(fit)
colasso:::plot.bilasso(fit)
colasso::bilasso_compare(y=y,cutoff=0,X=X)
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
set.seed(1)
grid <- expand.grid(prob=seq(from=0.1,to=0.2,length.out=101),
fac=seq(from=0.5,to=2,length.out=101))
grid <- grid[sample(seq_len(nrow(grid))),]
i <- 1
cat(i," ")
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
if(sd(y)==0){next}
colasso::bilasso_compare(y=y,cutoff=0,X=X)
set.seed(1)
grid <- expand.grid(prob=seq(from=0.1,to=0.2,length.out=101),
fac=seq(from=0.5,to=2,length.out=101))
grid <- grid[sample(seq_len(nrow(grid))),]
list <- list()
cat(i," ")
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
if(sd(y)==0){next}
fit <- colasso::bilasso(y=y,cutoff=0,X=X)
fit$trial.min
fit$trial.min$sigma
fit$trial$min$pi
fit$trial.min$pi
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
# data simulation
list <- .simulate(n=100,p=200)
y <- list$y; X <- list$X
# penalised regression
cutoff <- 1
foldid <- palasso:::.folds(y=y>cutoff,nfolds=10)
fit <- colasso::bilasso(y=y,cutoff=cutoff,X=X,foldid=foldid)
net <- list()
net$gaussian <- glmnet::cv.glmnet(y=y,x=X,family="gaussian",foldid=foldid)
net$binomial <- glmnet::cv.glmnet(y=y>cutoff,x=X,family="binomial",foldid=foldid)
# data simulation
list <- colasso:::.simulate(n=100,p=200)
y <- list$y; X <- list$X
# penalised regression
cutoff <- 1
foldid <- palasso:::.folds(y=y>cutoff,nfolds=10)
fit <- colasso::bilasso(y=y,cutoff=cutoff,X=X,foldid=foldid)
net <- list()
net$gaussian <- glmnet::cv.glmnet(y=y,x=X,family="gaussian",foldid=foldid)
net$binomial <- glmnet::cv.glmnet(y=y>cutoff,x=X,family="binomial",foldid=foldid)
dist <- "gaussian"
testthat::test_that("cross-validated loss",{
a <- fit[[dist]]$sigma.cvm
b <- net[[dist]]$cvm
diff <- abs(a[seq_along(b)]-b)
testthat::expect_true(all(diff<1e-06))
})
testthat::test_that("optimal lambda",{
a <- fit[[dist]]$lambda.min
b <- net[[dist]]$lambda.min
testthat::expect_true(a==b)
})
testthat::test_that("lambda sequence",{
a <- fit[[dist]]$lambda
b <- net[[dist]]$lambda
testthat::expect_true(all(a[seq_along(b)]==b))
})
testthat::test_that("predicted values",{
a <- stats::predict(object=fit[[dist]],newx=X)
b <- stats::predict(object=net[[dist]]$glmnet.fit,newx=X)
testthat::expect_true(all(a==b))
})
dist <- "binomial"
testthat::test_that("cross-validated loss",{
a <- fit[[dist]]$sigma.cvm
b <- net[[dist]]$cvm
diff <- abs(a[seq_along(b)]-b)
testthat::expect_true(all(diff<1e-06))
})
testthat::test_that("optimal lambda",{
a <- fit[[dist]]$lambda.min
b <- net[[dist]]$lambda.min
testthat::expect_true(a==b)
})
testthat::test_that("lambda sequence",{
a <- fit[[dist]]$lambda
b <- net[[dist]]$lambda
testthat::expect_true(all(a[seq_along(b)]==b))
})
testthat::test_that("predicted values",{
a <- stats::predict(object=fit[[dist]],newx=X)
b <- stats::predict(object=net[[dist]]$glmnet.fit,newx=X)
testthat::expect_true(all(a==b))
})
a <- predict.bilasso(x=fit,newx=X)$binomial
a <- colasso:::predict.bilasso(x=fit,newx=X)$binomial
colasso:::predict.bilasso(x=fit,newx=X)
fit
names(fit)
b <- as.numeric(stats::predict(object=net$binomial,newx=X,s="lambda.min",type="response"))
b
x=fit
newx=X
type <- "probability"
test <- x$info$test
.check(x=newx,type="matrix")
.check(x=type,type="string",values=c("probability","odds","log-odds"))
# linear, logistic and mixed
prob <- list()
link <- as.numeric(stats::predict(object=x$gaussian,
newx=newx,s=x$gaussian$lambda.min,type="response"))
prob$gaussian <- stats::pnorm(q=link,mean=x$cutoff,sd=x$info$sd.y)
prob$binomial <- as.numeric(stats::predict(object=x$binomial,
newx=newx,s=x$binomial$lambda.min,type="response"))
if(test$sigma){
prob$sigma <- stats::pnorm(q=link,mean=x$cutoff,sd=x$sigma.min) # original
}
.check <- colasso:::.check
test <- x$info$test
.check(x=newx,type="matrix")
.check(x=type,type="string",values=c("probability","odds","log-odds"))
# linear, logistic and mixed
prob <- list()
link <- as.numeric(stats::predict(object=x$gaussian,
newx=newx,s=x$gaussian$lambda.min,type="response"))
prob$gaussian <- stats::pnorm(q=link,mean=x$cutoff,sd=x$info$sd.y)
prob$binomial <- as.numeric(stats::predict(object=x$binomial,
newx=newx,s=x$binomial$lambda.min,type="response"))
if(test$sigma){
prob$sigma <- stats::pnorm(q=link,mean=x$cutoff,sd=x$sigma.min) # original
}
if(test$pi){
prob$pi <- x$pi.min*prob$gaussian + (1-x$pi.min)*prob$binomial # trial pi
}
if(test$max){
temp <- ((link-x$cutoff)/x$max.min + 1)/2 # trial max
prob$max <- pmax(0,pmin(temp,1)) # trial max
}
if(test$grid){
temp <- as.numeric(stats::predict(object=x$gaussian,
newx=newx,s=x$grid.min$lambda,type="response"))
prob$grid <- stats::pnorm(q=temp,mean=x$cutoff,sd=x$grid.min$sigma)
}
if(test$grid2){
temp <- as.numeric(stats::predict(object=x$gaussian,
newx=newx,s=x$grid2.min$lambda,type="response"))
prob$grid2 <- fit$grid2.min$pi*temp + (1-fit$grid2.min$pi)*prob$binomial
}
if(test$trial){
cont <- stats::pnorm(q=link,mean=x$cutoff,sd=x$trial.min$sigma)
prob$trial[foldid==k,i,j] <- x$trial.min$pi*cont + (1-x$trial.min$pi)*prob$binomial
}
if(test$trial){
cont <- stats::pnorm(q=link,mean=x$cutoff,sd=x$trial.min$sigma)
prob$trial <- x$trial.min$pi*cont + (1-x$trial.min$pi)*prob$binomial
}
# consistency tests
lapply(X=prob,FUN=function(p) .check(x=p,type="vector",min=0,max=1))
.equal(link>x$cutoff,prob$gaussian>0.5)
# transformation
if(type=="probability"){
frame <- prob
} else if(type=="odds"){
frame <- lapply(X=prob,FUN=function(x) x/(1-x))
} else if(type=="log-odds"){
frame <- lapply(X=prob,FUN=function(x) log(x/(1-x)))
} else {
stop("Invalid type.",call.=FALSE)
}
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
set.seed(1)
grid <- expand.grid(prob=seq(from=0.1,to=0.2,length.out=101),
fac=seq(from=0.5,to=2,length.out=101))
grid <- grid[sample(seq_len(nrow(grid))),]
list <- list()
i <- 1
cat(i," ")
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
fit <- colasso::bilasso(y=y,cutoff=0,X=X)
names(fit)
plot(fit)
olasso::plot.bilasso(fit)
colasso::plot.bilasso(fit)
colasso:::plot.bilasso(fit)
colasso::bilasso_compare(y=y,cutoff=0,X=X)
set.seed(1)
grid <- expand.grid(prob=seq(from=0.1,to=0.2,length.out=101),
fac=seq(from=0.5,to=2,length.out=101))
grid <- grid[sample(seq_len(nrow(grid))),]
list <- list()
for(i in 1:nrow(grid)){
cat(i," ")
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
if(sd(y)==0){next}
#fit <- colasso::bilasso(y=y,cutoff=0,X=X)
## colasso:::plot.bilasso(fit)
list[[i]] <- colasso::bilasso_compare(y=y,cutoff=0,X=X)
}
loss <- list()
name <- names(list[[1]])
for(i in seq_along(name)){
loss[[name[i]]] <- t(sapply(X=list,FUN=function(x) x[[name[i]]]))
}
t(sapply(loss,colMeans))
t(sapply(X=loss,FUN=function(x) apply(x,2,median)))
# change in deviance against AUC
diff <- loss$deviance[,"trial"]-loss$deviance[,"gaussian"]
median(diff); mean(diff); mean(diff<0)
wilcox.test(diff)$p.value; t.test(diff)$p.value
auc <- loss$auc[,"gaussian"]
plot(x=auc,y=diff); abline(h=0,lty=2,col="red")
# change in deviance against AUC
diff <- loss$deviance[,"trial"]-loss$deviance[,"binomial"]
median(diff); mean(diff); mean(diff<0)
wilcox.test(diff)$p.value; t.test(diff)$p.value
auc <- loss$auc[,"gaussian"]
plot(x=auc,y=diff); abline(h=0,lty=2,col="red")
predict(Fit)
predict(fit)
predict(net)
fit <- colasso::bilasso(y=y,cutoff=0,X=X)
olasso:::predict.bilasso(fit)
colasso:::predict.bilasso(fit)
colasso:::predict.bilasso(fit,newx=X)
#fit <- colasso::bilasso(y=y,cutoff=0,X=X)
## colasso:::predict.bilasso(fit,newx=X)
## colasso:::plot.bilasso(fit)
list[[i]] <- colasso::bilasso_compare(y=y,cutoff=0,X=X)
pred <- colasso:::predict.bilasso(fit,newx=X)
head(pred)
cor(pred)
fit$pi.min
fit$trial.min$pi
#################
### colasso ###
#################
#--- generate toydata ----------------------------------------------------------
set.seed(1)
#toydata <- NULL
#save(toydata,file=file.path("C:/Users/armin.rauschenberger/Desktop/package/colasso/data/toydata.R"))
#--- compile package -----------------------------------------------------------
rm(list=ls())
name <- "colasso"
#load("D:/colasso/package/toydata.RData")
pkg <- "C:/Users/armin.rauschenberger/Desktop/colasso/colasso"
setwd(dir=pkg)
devtools::as.package(x=pkg,create=FALSE)
devtools::load_all(path=pkg)
#usethis::use_data(toydata,overwrite=TRUE)
devtools::document(pkg=pkg)
unlink(file.path(pkg,"vignettes","figure"),recursive=TRUE)
all <- dir(file.path(pkg,"vignettes"))
#delete <- "..."
#sapply(delete,function(x) file.remove(file.path(pkg,"vignettes",x)))
setwd(dir=pkg)
unlink(file.path(pkg,"docs"),recursive=TRUE)
pkgdown::build_site(pkg=pkg)
file.remove(file.path(pkg,".Rbuildignore"))
usethis::use_build_ignore(files=c("Readme.Rmd",".travis.yml","_pkgdown.yml","docs","cran-comments.md","appveyor.yml"))
devtools::check(pkg=pkg,quiet=FALSE,manual=TRUE)
devtools::install(pkg=pkg,upgrade=FALSE)
set.seed(1)
grid <- expand.grid(prob=seq(from=0.1,to=0.2,length.out=101),
fac=seq(from=0.5,to=2,length.out=101))
grid <- grid[sample(seq_len(nrow(grid))),]
list <- list()
for(i in 1:nrow(grid)){
cat(i," ")
temp <- colasso:::.simulate(n=100,p=200,prob=grid$prob[i],fac=grid$fac[i])
y <- temp$y; X <- temp$X
if(sd(y)==0){next}
#fit <- colasso::bilasso(y=y,cutoff=0,X=X)
## pred <- colasso:::predict.bilasso(fit,newx=X)
## colasso:::plot.bilasso(fit)
list[[i]] <- colasso::bilasso_compare(y=y,cutoff=0,X=X)
}
loss <- list()
name <- names(list[[1]])
for(i in seq_along(name)){
loss[[name[i]]] <- t(sapply(X=list,FUN=function(x) x[[name[i]]]))
}
t(sapply(loss,colMeans))
t(sapply(X=loss,FUN=function(x) apply(x,2,median)))
# change in deviance against AUC
diff <- loss$deviance[,"trial"]-loss$deviance[,"binomial"]
median(diff); mean(diff); mean(diff<0)
wilcox.test(diff)$p.value; t.test(diff)$p.value
auc <- loss$auc[,"gaussian"]
plot(x=auc,y=diff); abline(h=0,lty=2,col="red")
......@@ -80,7 +80,7 @@
#' X <- matrix(rnorm(n*p),nrow=n,ncol=p)
#' net <- bilasso(y=y,cutoff=0,X=X)
#' ### Add ... to all glmnet::glmnet calls !!! ###
bilasso <- function(y,cutoff,X,nsigma=100,sigma=NULL,nfolds=10,foldid=NULL,type.measure="deviance",logistic=TRUE,...){
bilasso <- function(y,cutoff,X,npi=100,nsigma=100,sigma=NULL,nfolds=10,foldid=NULL,type.measure="deviance",logistic=TRUE,...){
#--- temporary ---
# cutoff <- 0; nsigma <- 99; sigma <- NULL; nfolds <- 10; foldid <- NULL; type.measure <- "deviance"; logistic <- TRUE
......@@ -101,6 +101,7 @@ bilasso <- function(y,cutoff,X,nsigma=100,sigma=NULL,nfolds=10,foldid=NULL,type.
colasso:::.check(x=cutoff,type="scalar",min=min(y),max=max(y))
colasso:::.check(x=X,type="matrix")
if(length(y)!=nrow(X)){stop("Contradictory sample size.",call.=FALSE)}
colasso:::.check(x=npi,type="scalar",min=1)
colasso:::.check(x=nsigma,type="scalar",min=1)
colasso:::.check(x=sigma,type="vector",min=.Machine$double.eps,null=TRUE)
colasso:::.check(x=nfolds,type="scalar",min=3)
......@@ -142,8 +143,8 @@ bilasso <- function(y,cutoff,X,nsigma=100,sigma=NULL,nfolds=10,foldid=NULL,type.
names(fit$lambda) <- lab.lambda
if(test$pi){
fit$pi <- seq(from=0,to=1,length.out=100)
lab.pi <- paste0("pi",seq_len(100))
fit$pi <- seq(from=0,to=1,length.out=npi)
lab.pi <- paste0("pi",seq_len(npi))
}
if(test$max){
fit$max <- exp(seq(from=log(0.05*max(abs(y-cutoff))),
......@@ -178,11 +179,11 @@ bilasso <- function(y,cutoff,X,nsigma=100,sigma=NULL,nfolds=10,foldid=NULL,type.
}
if(test$grid2){
dimnames <- list(NULL,lab.pi,lab.lambda)
pred$grid2 <- array(data=NA,dim=c(n,100,nlambda),dimnames=dimnames)
pred$grid2 <- array(data=NA,dim=c(n,npi,nlambda),dimnames=dimnames)
}
if(test$trial){
dimnames <- list(NULL,lab.sigma,lab.pi)
pred$trial <- array(data=NA,dim=c(n,nsigma,100),dimnames=dimnames)
pred$trial <- array(data=NA,dim=c(n,nsigma,npi),dimnames=dimnames)
}
if(test$unit){
dimnames <- list(NULL,lab.s1,lab.s2)
......
......@@ -111,8 +111,9 @@
</div>
<pre class="usage"><span class='fu'>bilasso</span>(<span class='no'>y</span>, <span class='no'>cutoff</span>, <span class='no'>X</span>, <span class='kw'>nsigma</span> <span class='kw'>=</span> <span class='fl'>100</span>, <span class='kw'>sigma</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <span class='kw'>nfolds</span> <span class='kw'>=</span> <span class='fl'>10</span>,
<span class='kw'>foldid</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <span class='kw'>type.measure</span> <span class='kw'>=</span> <span class='st'>"deviance"</span>, <span class='kw'>logistic</span> <span class='kw'>=</span> <span class='fl'>TRUE</span>, <span class='no'>...</span>)</pre>
<pre class="usage"><span class='fu'>bilasso</span>(<span class='no'>y</span>, <span class='no'>cutoff</span>, <span class='no'>X</span>, <span class='kw'>npi</span> <span class='kw'>=</span> <span class='fl'>100</span>, <span class='kw'>nsigma</span> <span class='kw'>=</span> <span class='fl'>100</span>, <span class='kw'>sigma</span> <span class='kw'>=</span> <span class='kw'>NULL</span>,
<span class='kw'>nfolds</span> <span class='kw'>=</span> <span class='fl'>10</span>, <span class='kw'>foldid</span> <span class='kw'>=</span> <span class='kw'>NULL</span>, <span class='kw'>type.measure</span> <span class='kw'>=</span> <span class='st'>"deviance"</span>,
<span class='kw'>logistic</span> <span class='kw'>=</span> <span class='fl'>TRUE</span>, <span class='no'>...</span>)</pre>
<h2 class="hasAnchor" id="arguments"><a class="anchor" href="#arguments"></a>Arguments</h2>
<table class="ref-arguments">
......