Skip to content

Commit

Permalink
abrem 0.1.23: Many bugfixes and some small features implemented. This…
Browse files Browse the repository at this point in the history 
… commit should be compatible with debias 0.1.9 (available on r-forge) and abremPivotals 0.2.9 (commit ID 2b08a98d)

Signed-off-by: Jurgen Symynck <[email protected]>
  • Loading branch information
Jurgen Symynck committed Nov 2, 2014
1 parent 764e030 commit 0b0b4a8
Show file tree
Hide file tree
Showing 29 changed files with 502 additions and 446 deletions.
14 changes: 14 additions & 0 deletions ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,17 @@
2014-11-02 Jurgen Symynck <[email protected]>

* upgraded abrem 0.1.21 to 0.1.23 (development version)
* many bugfixes, manual cleanup;
* Uses packages debias 0.1.9 (available on r-forge) and abremPivotals 0.2.9 (available on github, commit ID 2b08a98): This release uses the getPPP(na.rm=...) option that will be dropped in future abremPivotals and abrem releases.
* Added "canvas" option to specify type of plotting canvas to be used (option "log" is still present). The canvas type now shows in the plot.
* Added "axes" option to omit specified axes on the plot, added "frame.plot" argument to plot a frame around the plot. The default plot now only has lower and left axes.

* Abrem.R (Abrem): dropped support for "time" and "fail" arguments, in favor of the default "x", to be consistent with abremPivotals and abremDebias.
* calculateSingleFit.R (calculateSingleFit):
dropped support for "rr2", "mle2", "mle3", "mle-rba2" and "mle-rba3". The decision was made that the C++ code should be the default, while the R code (lm(), optim(), ...) is only provided as an example. "rr2" has been replaced by adding an option "use.lm" in argument "method.fit".
* calculateSingleConf.R (calculateSingleConf):
Added support for limiting the confidence bounds to the unreliability levels to those that were explicitly passed using argument 'unrel'.

2014-10-11 Jurgen Symynck <[email protected]>

* upgraded abrem 0.1.14 to 0.1.21:
Expand Down
4 changes: 2 additions & 2 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
Package: abrem
Type: Package
Title: Abernethy Reliability Methods
Version: 0.1.21
Date: October 11, 2014
Version: 0.1.23
Date: November 02, 2014
Author: Jurgen Symynck <[email protected]>
Maintainer: Jurgen Symynck <[email protected]>
Description: Implementation of reliability methods presented in "The New Weibull Handbook", Fifth Edition by Dr. Robert B. Abernethy. This package is dedicated to the control and view of models developed in dependant packages abremPivotals and abremDebias (under construction) implemented using the R object model.
Expand Down
88 changes: 38 additions & 50 deletions R/Abrem.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,29 +33,42 @@
# +-----------------------------------+

Abrem <- function(x,...){
# TODO: add code to convert a Surv() object into an abrem object
#arg <- list(...)
arg <- splitargs(...)

# arg2 <- arg[!(names(arg) %in% names(options.abrem()))]
# extract the arguments that are NOT abrem options.
opa <- modifyList(options.abrem(), arg$opa)
ret <- list()
NA.present <- FALSE
# remember if there were any NA values in the time argument(s)
class(ret) <- "abrem"
timeorder <- c()
# lowest <- 1
if(!missing(x)){
ret$data <- NULL
if(is.vector(x) || is.numeric(x)){
# TODO: the effects of adding is.numeric(x) are not tested thoroughly yet...
if(opa$verbosity >= 2)message(
'Abrem: Argument \"x\" is a (numeric) vector of (life-)time observations...')
if(any(is.na(x))) timeorder <- 1:length(x)
if(any(is.na(x))){
NA.present <- TRUE
timeorder <- 1:length(x)
}
else timeorder <- order(x)
# the above is to prevent ordering attempts when NA values are
# present in the lifetime observation vector.
# having NA values implies that the data must be ordered.
ret$data <- data.frame(time=x[timeorder],event=1)
if(!is.null(arg$rem$susp)){
if(is.vector(arg$rem$susp)){
if(opa$verbosity >= 2)message(
'Abrem: Argument \"susp\" is vector of right-censored (suspended) (life-)time observations...')
# x is now consireded complete failures
if(!NA.present){
timeorder <- order(c(x,arg$rem$susp))
ret$data <- data.frame(time=c(x,arg$rem$susp)[timeorder],
event=c(rep(1,length(x)),rep(0,length(arg$rem$susp)))[timeorder])
}else{stop('Argument \"x\" cannot contain NA values when \"susp\" is also passed.')}
# TODO: a better description of the error is probably needed here...
}else{stop('Argument \"susp\" must be a vector.')}
}else{
ret$data <- data.frame(time=x[timeorder],event=1)
}
}
if(is.data.frame(x)){
if(!is.null(x$time) && !is.null(x$event)){
Expand All @@ -68,39 +81,26 @@ Abrem <- function(x,...){
# ret$data$event <- 1
# # temporarily set event vector to 1
}else{
stop(': Argument \"x\" is missing $time and/or ",
stop('Argument \"x\" is missing $time and/or ",
"$event columns...')
}
}
}else{
ti <- c(arg$rem$time,arg$rem$fail)
if(xor(!is.null(arg$rem$time), !is.null(arg$rem$fail))){
if(is.vector(ti)){
if(opa$verbosity >= 2)message(
'Abrem: Argument \"time\" or \"fail\" is vector of complete (life-)time observations...')
if(any(is.na(ti))) timeorder <- 1:length(arg$rem$time)
else timeorder <- order(ti)
ret$data <- data.frame(time=ti[timeorder],event=1)
}else{stop('Argument \"time\" or fail\" must be vector.')}
}
if(!is.null(arg$rem$susp)){
if(is.vector(arg$rem$susp)){
if(opa$verbosity >= 2)message(
'Abrem: Argument \"susp\" is vector of right-censored (suspended) (life-)time observations...')
timeorder <- order(c(ti,arg$rem$susp))
ret$data <- data.frame(time=c(ti,arg$rem$susp)[timeorder],
event=c(rep(1,length(ti)),rep(0,length(arg$rem$susp)))[timeorder])
}else{stop('Argument \"susp\" must be a vector.')}
}
#else{stop("No (life-)time observations were provided.")}
}

### setting the event vector correctly ###
if(!is.null(arg$rem$event) && !is.null(ret$data)){
if(is.vector(arg$rem$event)){
if(opa$verbosity >= 2)message(
'Abrem: Argument \"event\" is event vector...')
ret$data$event <- arg$rem$event[timeorder]
if((l1 <- length(arg$rem$event)) != (l2 <- length(timeorder))){
mes <- paste0('Length of argument \"event\" (',l1,
') does not match the size of the time data (',l2,').')
stop(mes)
# since time dat is in x or x$time, I use the vector
# 'timeorder' here to get the length of the time data
}else{
ret$data$event <- arg$rem$event[timeorder]
}
}
}
addpppcolumns <- function(ppos){
Expand All @@ -111,28 +111,19 @@ Abrem <- function(x,...){
# experimental code, in combination with support in
# abremPivotals::gePPP for event vector arguments

ret$data <<-
ret$data$ppp <<-
###[ret$data$event==1,'ppp'] <<-
abremPivotals::getPPP(
x=ret$data$event,
ppos=ppos,na.rm=FALSE)#$ppp
ppos=ppos,na.rm=FALSE)$ppp
}else{
ret$data <<-
#[ret$data$event==1,'ppp'] <<-
abremPivotals::getPPP(
ret$data <<- abremPivotals::getPPP(
x=ret$data$time[ret$data$event==1],
s=ret$data$time[ret$data$event==0],
ppos=ppos,na.rm=FALSE)#$ppp
# ret$data[ret$data$event==1,'ppp'] <<-
# abremPivotals::getPPP(
# x=ret$data$time[ret$data$event==1],
# s=ret$data$time[ret$data$event==0],
# ppos=ppos)$ppp
ppos=ppos,na.rm=FALSE)
}
whi <- which(colnames(ret$data)=="ppp")
colnames(ret$data)[whi] <<- paste0("ppp.",ppos)
# <<- c( colnames(ret$data)[-ncol(ret$data)],
# paste0("ppp.",ppos))
# renaming the added column to include the type of ranking
# Jurgen October 7, 2014: not sure why I didn't implement this
# solution earlier
Expand All @@ -148,17 +139,14 @@ Abrem <- function(x,...){
do.call(addpppcolumns,list("km"))
}
ret$n <- length(ret$data$time)
# TODO: this assumes that any NA time (in any present
# This assumes that any NA time (in any present
# in the time column is there for a good reason:
# accompanied with a censoring indicator (0 or FALSE)
# TODO: check if the above code is still valid!
# this feature must be researched in combination wirh abremPivotals:lslr()
ret$fail <- sum(ret$data$event)
# TODO: Warning; this only works when event can take values of 0 and one!
# This can be solved when events are changed to factors, as they really are
# This can be solved when events are changed to factors.
ret$susp <- ret$n-ret$fail
ret$options <- opa
# always store a full copy of the options.abrem structure here
ret
# TODO: check what to do with the automatically added row names that are sometimes out of order
}
3 changes: 0 additions & 3 deletions R/abrem.conf.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,6 @@

abrem.conf <- function(x,which="all",...){
# x is a single Abrem or a list of Abrem objects
# supported_blifeconf <- c("mcpivotals","bbb")
if(missing(x)){
stop('Argument \"x\" is missing.')
}else{
Expand All @@ -44,12 +43,10 @@ abrem.conf <- function(x,which="all",...){
"a list of \"abrem\" objects.')
}
dr <- findMaxDataRange(x,0)
# for reasonably large confidence bounds
calculateConfsInAbrem <- function(abrem){
if(!is.null(abrem$fit)){
abrem$fit <- lapply(abrem$fit,calculateSingleConf,
opadata=abrem$options,datarange=dr,...)
# TODO: add error detection
}
abrem
}
Expand Down
14 changes: 7 additions & 7 deletions R/abrem.fit.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,13 +37,14 @@ abrem.fit <- function(x,...){
supported_dist <- c(
"weibull","weibull2p","weibull3p",
"lognormal","lognormal2p","lognormal3p")
supported_fit <- c("rr","rr2","mle","mle2","mle3","mle-rba","mle2-rba","mle3-rba")
# supported_fit <- c("rr","rr2","mle","mle2","mle3","mle-rba","mle2-rba","mle3-rba")
supported_fit <- c("rr","mle","mle-rba")
if(missing(x)){
stop("Argument \"x\" is missing.")
}else{
if(identical(class(x),"abrem")) x <- list(x)
if(!all(sapply(x,function(x)identical(class(x),"abrem")))){
stop("\"x\" argument is not of class \"abrem\" or ",
stop("Argument \"x\" is not of class \"abrem\" or ",
"a list of \"abrem\" objects.")
}
# from here on, x is a list of one or more abrem objects
Expand All @@ -54,7 +55,7 @@ abrem.fit <- function(x,...){
opa <- modifyList(opa, list(...))
if(is.null(opa$dist)){
if(opa$verbosity >= 1)message("abrem.fit : ",
": Target distribution defaults to weibull2p.")
"Target distribution defaults to weibull2p.")
opa$dist <- "weibull2p"
}else{
if(length(opa$dist)>1)
Expand All @@ -68,25 +69,24 @@ abrem.fit <- function(x,...){
}else{
if(is.null(opa$method.fit)){
if(opa$verbosity >= 1)message("abrem.fit : ",
': Fit method defaults to \"rr\", \"xony\".')
'Fit method defaults to \"rr\", \"xony\".')
opa$method.fit <- c("rr","xony")
}else{
fits <- length(which(opa$method.fit %in% supported_fit))
if(fits > 1){
stop("Only one fit method should be supplied.")
}else{
if(any(c("rr","rr2") %in% tolower(opa$method.fit))){
if("rr" %in% tolower(opa$method.fit)){
if(!any(c("xony","yonx") %in%
tolower(opa$method.fit))){
if(opa$verbosity >= 1){
message("abrem.fit : ",
': Fit method \"rr\" defaults to \"xony\"')
'Fit method \"rr\" defaults to \"xony\"')
opa$method.fit <- c(opa$method.fit,"xony")
}
}
}
x <- lapply(x,calculateSingleFit,...)
# TODO: only one object or list of abrem objects?
}
}
}
Expand Down
15 changes: 5 additions & 10 deletions R/buildListOfLegends.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,18 +34,13 @@

buildListOfLegends <- function(abrem,v,isplotlegend,...){
ret <- NULL
if(!is.null(abrem$fit) && any(sapply(abrem$fit,function(fi)!is.null(fi)))){
# TODO:
# if(!is.null(abrem$fit)){
# check if any non-NULL list holds only NULL items
# this is needed for dealing with failed fit attempts
# that currently take the form of
# abrem$fit[i] <- list(NULL)
# ret <- unlist(lapply(x$fit,buildSingleFitLegend,
# opadata=x$options,...),FALSE)
ret <- lapply(abrem$fit,buildSingleFitLegend,
emptyfits <- sapply(abrem$fit,function(fi)is.null(fi))
if(!is.null(abrem$fit) && sum(!emptyfits > 0)){
ret <- lapply(abrem$fit[!emptyfits],buildSingleFitLegend,
opadata=abrem$options,...)
# TODO: test if abrem$fit[!emptyfits] is to be used and not abrem$fit[[!emptyfits]]
}else{
# no fits present in the abrem object
if(abrem$options$is.plot.legend && isplotlegend){
ret <- list(buildSingleDataLegend(abrem,opadata=abrem$options,...))
if(v >= 1)message(
Expand Down
38 changes: 21 additions & 17 deletions R/buildSingleDataLegend.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,22 +45,26 @@ buildSingleDataLegend <- function(x,opadata,...){
removeBadLegendEntries <- function(e){
if(!is.null(e))!is.na(e$legend) else FALSE
}
if(length(li)>0)li <- li[sapply(li,removeBadLegendEntries)]
else li <- ""
# remove list items where the legend text = NA
fu <- function(x,i){if(i %in% names(x))x[[i]]}
fu2 <- function(i,x){lapply(x,fu,i=i)}
items <- c("legend","lty","lwd","pch","col")
le <- lapply(items,fu2,li)
names(le) <- items
if(identical(label <- opadata$label,""))label <- NULL
le$rect <- legend(
"bottomright",
legend=le$legend,
title=label,
cex = opadata$legend.text.size,
plot=FALSE)$rect
le$label <- opadata$label
le$legend.text.size <- opadata$legend.text.size
if(length(li)>0){
li <- li[sapply(li,removeBadLegendEntries)]
### Oct 2014:
### moved the following code inside the if(length(li)>0){statement
fu <- function(x,i){if(i %in% names(x))x[[i]]}
fu2 <- function(i,x){lapply(x,fu,i=i)}
items <- c("legend","lty","lwd","pch","col")
le <- lapply(items,fu2,li)
names(le) <- items
if(identical(label <- opadata$label,""))label <- NULL
le$rect <- legend(
"bottomright",
legend=le$legend,
title=label,
cex = opadata$legend.text.size,
plot=FALSE)$rect
le$label <- opadata$label
le$legend.text.size <- opadata$legend.text.size
}else le <- NULL
#else li <- ""
# remove list items where the legend text = NA
le
}
47 changes: 28 additions & 19 deletions R/buildSingleFitLegend.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -107,26 +107,35 @@ buildSingleFitLegend <- function(fit,opadata,...){
removeBadLegendEntries <- function(e){
if(!is.null(e))!is.na(e$legend) else FALSE
}
if(length(li)>0)li <- li[sapply(li,removeBadLegendEntries)]
else li <- ""
if(length(li)>0){
li <- li[sapply(li,removeBadLegendEntries)]
### Oct 2014:
### moved the following code inside the if(length(li)>0){statement
fu <- function(x,i){if(i %in% names(x))x[[i]]}
fu2 <- function(i,x){lapply(x,fu,i=i)}
items <- c("legend","lty","lwd","pch","col")
le <- lapply(items,fu2,li)
# above assumes that li is valid
names(le) <- items
if(identical(label <- opafit$label,""))label <- NULL
le$rect <- legend(
"bottomright",
# "topright",
legend=le$legend,
title=label,
cex = opafit$legend.text.size,
# inset=0.1,
# merge = TRUE,
plot=FALSE)$rect
le$label <- opafit$label
le$legend.text.size <- opafit$legend.text.size
}
else le <- NULL
#else li <- ""
# remove list items where the legend text = NA
fu <- function(x,i){if(i %in% names(x))x[[i]]}
fu2 <- function(i,x){lapply(x,fu,i=i)}
items <- c("legend","lty","lwd","pch","col")
le <- lapply(items,fu2,li)
names(le) <- items
if(identical(label <- opafit$label,""))label <- NULL
le$rect <- legend(
"bottomright",
# "topright",
legend=le$legend,
title=label,
cex = opafit$legend.text.size,
# inset=0.1,
# merge = TRUE,
plot=FALSE)$rect
le$label <- opafit$label
le$legend.text.size <- opafit$legend.text.size
# Oct 2014: why is else li <-"" here? I assume that when
# there is nothing in li then le should be NULL

}
le
}
Loading

0 comments on commit 0b0b4a8

Please sign in to comment.