Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Armin Rauschenberger
joinet
Commits
46553707
Commit
46553707
authored
Jan 08, 2019
by
Armin Rauschenberger
Browse files
automation
parent
83995670
Changes
1
Hide whitespace changes
Inline
Side-by-side
R/bilasso.R
View file @
46553707
...
...
@@ -83,7 +83,7 @@
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
# cutoff <- 0;
npi <- 100;
nsigma <- 99; sigma <- NULL; nfolds <- 10; foldid <- NULL; type.measure <- "deviance"; logistic <- TRUE
test
<-
list
()
test
$
sigma
<-
TRUE
...
...
@@ -94,7 +94,9 @@ bilasso <- function(y,cutoff,X,npi=100,nsigma=100,sigma=NULL,nfolds=10,foldid=NU
test
$
grid
<-
TRUE
test
$
max
<-
FALSE
test
$
grid2
<-
FALSE
test
$
calibrate
<-
FALSE
#--- checks ---
colasso
:::
.check
(
x
=
y
,
type
=
"vector"
)
if
(
all
(
y
%in%
c
(
0
,
1
))){
warning
(
"Binary response."
,
call.
=
FALSE
)}
...
...
@@ -189,7 +191,7 @@ bilasso <- function(y,cutoff,X,npi=100,nsigma=100,sigma=NULL,nfolds=10,foldid=NU
dimnames
<-
list
(
NULL
,
lab.s1
,
lab.s2
)
pred
$
unit
<-
array
(
data
=
NA
,
dim
=
c
(
n
,
100
,
100
),
dimnames
=
dimnames
)
}
for
(
k
in
seq_len
(
nfolds
)){
y0
<-
y
[
foldid
!=
k
]
...
...
@@ -332,9 +334,9 @@ bilasso <- function(y,cutoff,X,npi=100,nsigma=100,sigma=NULL,nfolds=10,foldid=NU
if
(
test
$
trial
){
dimnames
<-
list
(
lab.sigma
,
lab.pi
)
fit
$
trial.cvm
<-
matrix
(
data
=
NA
,
nrow
=
nsigma
,
ncol
=
100
,
dimnames
=
dimnames
)
fit
$
trial.cvm
<-
matrix
(
data
=
NA
,
nrow
=
nsigma
,
ncol
=
npi
,
dimnames
=
dimnames
)
for
(
i
in
seq_len
(
nsigma
)){
for
(
j
in
seq_len
(
100
)){
for
(
j
in
seq_len
(
npi
)){
fit
$
trial.cvm
[
i
,
j
]
<-
colasso
:::
.loss
(
y
=
z
,
fit
=
pred
$
trial
[,
i
,
j
],
family
=
"binomial"
,
type.measure
=
type.measure
)[[
1
]]
}
}
...
...
@@ -358,6 +360,11 @@ bilasso <- function(y,cutoff,X,npi=100,nsigma=100,sigma=NULL,nfolds=10,foldid=NU
if
(
!
cond
){
stop
(
"internal mistake"
,
call.
=
FALSE
)}
}
# calibrate
if
(
test
$
calibrate
){
fit
$
calibrate
<-
CalibratR
::
calibrate
(
actual
=
z
,
predicted
=
pred
$
y
[,
which.min
(
fit
$
gaussian
$
cvm
)],
nCores
=
1
,
model_idx
=
5
)
$
calibration_models
}
#--- return ---
fit
$
cutoff
<-
cutoff
fit
$
info
<-
list
(
type.measure
=
type.measure
,
...
...
@@ -503,6 +510,10 @@ predict.bilasso <- function(x,newx,type="probability"){
if
(
test
$
unit
){
prob
$
unit
<-
.prob
(
x
=
link
,
cutoff
=
x
$
cutoff
,
shape1
=
x
$
unit.min
$
shape1
,
shape2
=
x
$
unit.min
$
shape2
)
}
if
(
test
$
calibrate
){
prob
$
calibrate
<-
CalibratR
::
predict_calibratR
(
calibration_models
=
x
$
calibrate
,
new
=
link
,
nCores
=
1
)
$
GUESS_2
}
# consistency tests
lapply
(
X
=
prob
,
FUN
=
function
(
p
)
.check
(
x
=
p
,
type
=
"vector"
,
min
=
0
,
max
=
1
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment