Nothing
R/Legend.R
In WeibullR: Weibull Analysis for Reliability Engineering
Defines functions
Blifestring
bsll
buildSingleFitLegend
buildSingleDataLegend
legendConf
legendConf <- function(fit,conftype,opadata,...){
if(!is.null(fit)){
if(!is.null(fit$options))
opafit <- modifyList(opadata,fit$options)
opafit <- modifyList(opafit,list(...))
if(identical(tolower(conftype),"blives")){
if(!is.null(fit$conf)){
for.each.blicon <- function(blicon){
if(!is.null(blicon$options)){
opaconf <- modifyList(opafit,blicon$options)
}else{opaconf <- opafit}
if(opaconf$in.legend){
# TODO: correct usage of this logical value?
li <- list()
li[[1]] <- bsll(legend=paste0("CI bounds, type = ",
ifelse(is.null(blicon$type),"NA",
paste0("\"",blicon$type,"\""))),
col=opaconf$col,lwd=opaconf$lwd,lty=opaconf$lty)
li[[2]] <- bsll(legend=paste0(" CI = ",
ifelse(is.null(blicon$ci),"NA",
paste0(signif(blicon$ci*100,4)," [%]")),
ifelse(is.null(blicon$dof),"",
paste0(", dof = ",blicon$dof)),
ifelse(is.null(blicon$S),"",
paste0(", S = ",blicon$S))))
if(opaconf$in.legend.blives){
ssCL<- signif((1-(1-blicon$ci)/2)*100,4)
li[[3]] <- bsll(legend=paste0("B-life ssCL = ",
ifelse(is.null(blicon$ci),"NA",
paste0(ssCL," [%]"))))
## keep the params in a list object to pass in as args to Blifestring
## params <- unlist(list(beta=fit$beta,eta=fit$eta,t0=fit$t0,
## meanlog=fit$meanlog,sdlog=fit$sdlog,rate=fit$rate))
params <- list(beta=fit$beta,eta=fit$eta,t0=fit$t0,
meanlog=fit$meanlog,sdlog=fit$sdlog,rate=fit$rate)
if(is.null(bl <- blicon$blife.pts))bl <- opaconf$blife.pts
fu <- function(bl){
bsll(legend=Blifestring(bl,blicon,opafit$signif,params))
}
c(li,lapply(bl,fu))
}else(li)
}else NULL
}
#mtrace(for.each.blicon)
unlist(lapply(fit$conf,for.each.blicon),FALSE)
# TODO: replace by do.call ?
}else{NULL}
}
}else{NULL}
}
buildSingleDataLegend <- function(x,opadata,...){
arg <- list(...)
si <- function(number)signif(number,opadata$signif)
li <- list()
if(opadata$in.legend){
li[[10]] <- bsll(legend=paste0("ranks = ",opadata$pp[1]),
col=opadata$col,pch=opadata$pch,lwd=opadata$lwd.points)
if(is.null(x$data$dlines)) {
li[[15]] <- bsll(legend=paste0("n (fail | cens.) = ",x$n,
" (",x$fail," | ",x$cens,")"))
}else{
li[[15]] <- bsll(legend=paste0("n (f | s | d | i) = ",x$n,
" (",x$fail," | ",x$cens," | ",x$discovery," | ",x$interval,")"))
}
}
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}
supported_position <- c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", "center")
if(!any(tolower(opadata$legend.position) %in% supported_position)){
warning(paste0(opadata$legend.position," is not a supported legend position, bottomright applied"))
opa.data$legend.position<-"bottomright"
}
if(!is.numeric(opadata$legend.inset) || any(opadata$legend.inset<0) || any(opadata$legend.inset>1)) {
warning("legend.inset to be fractional graph width and height (0 and 1) inclusive \n
default c(0,0) applied.")
opadata$legend.inset<- c(0,0)
}
le$rect <- legend(
tolower(opadata$legend.position),
# "bottomright",
inset=opadata$legend.inset,
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
# le$legend.text.width <- opadata$legend.text.width
le
}
buildSingleFitLegend <- function(fit,opadata,...){
arg <- list(...)
if(!is.null(fit$options)){
opafit <- modifyList(opadata,fit$options)
}else{opafit <- opadata}
opafit <- modifyList(opafit,list(...))
t0 <- NULL
le <- NULL
if(opafit$is.plot.legend){
## removing threshold effects, when needed t0 is fit$t0 fit$modified indicates data modification by t0
#if(is.logical(opafit$threshold))if(opafit$threshold){
# if(is.logical(opadata$threshold)){if(opadata$threshold)
# warning("opafit$threshold and opadata$threshold are logical values but numeric values were expected. Proceeding...")
# }else{
# reuse the t0 value from the data level
# t0 <- opadata$threshold
# }
#}
#if(is.numeric(opafit$threshold))t0 <- opafit$threshold
si <- function(number)signif(number,opafit$signif)
# shorter writing form for signif()
li <- list()
if(opadata$in.legend){
modstr<-""
if(fit$modified) modstr<- "*t0 mod* "
li[[10]] <- bsll(legend=paste0(modstr,"ranks = ",opafit$pp[1]),
col=opadata$col,pch=opadata$pch,lwd=opadata$lwd.points)
## I don't understand why this becomes necessary with a fit
## Data types should be defined on entry with wblr object creation
## This is one reason for the redundant placement of data types in each fit
if((fit$discovery+fit$interval)==0) {
li[[15]] <- bsll(legend=paste0("n (fail | cens.) = ",fit$n,
" (",fit$fail," | ",fit$cens,")"))
}else{
li[[15]] <- bsll(legend=paste0("n (f | s | d | i) = ",fit$n,
" (",fit$fail," | ",fit$cens," | ",fit$discovery," | ",fit$interval,")"))
}
}
if(opafit$in.legend){
li[[20]] <- bsll(legend = paste0(fit$options$dist," (",
paste0(fit$options$method.fit,collapse=", "),")"),
col=opafit$col,lwd=opafit$lwd,lty=opafit$lty)
li[[30]] <- bsll(legend=ifelse(is.null(fit$rate),NA,
paste0("rate = ",si(fit$rate))))
li[[40]] <- bsll(legend=ifelse(is.null(fit$meanlog),NA,
paste0("mean(log) = ",si(exp(fit$meanlog))," (",
si(fit$meanlog),")")))
li[[50]] <- bsll(legend=ifelse(is.null(fit$sdlog),NA,
paste0("sd(log) = ",si(exp(fit$sdlog))," (",
si(fit$sdlog),")")))
li[[60]] <- bsll(legend=ifelse(is.null(fit$beta),NA,
paste0("beta = ",si(fit$beta))))
li[[70]] <- bsll(legend=ifelse(is.null(fit$eta),NA,
paste0("eta = ",si(fit$eta))))
li[[80]] <- bsll(legend=ifelse(is.null(fit$t0),NA,
paste0("t0 = ",si(fit$t0))))
if(!is.null(fit$gof) && opafit$in.legend.gof){
if(!is.null(fit$gof$r2)){
if(!is.null(fit$gof$ccc2)){
li[[100]] <- bsll(legend=paste0("r^2 | CCC^2 = ",
si(fit$gof$r2)," | ",si(fit$gof$ccc2),
ifelse(fit$gof$r2>=fit$gof$ccc2," (good)"," (BAD)")))
}else{
li[[100]] <- bsll(legend=paste0("r^2 = ",si(fit$gof$r2)))
}
}
if(!is.null(fit$gof$loglik)){
li[[110]] <- bsll(legend=paste0("loglik = ",si(fit$gof$loglik)))
}
li[[120]] <- bsll(
legend=ifelse(is.null(fit$gof$prr),NA,
#paste0("prr = ",si(fit$gof$prr)," (S=",
#ifelse(is.null(fit$gof$S),"NA",fit$gof$S),")")))
paste0("prr = ",si(fit$gof$prr)," by corr.")
)
)
}
}
#leconfpos <- length(na.omit(unlist(li))) + 1
# where displaying confidence info begins
leconf <- legendConf(fit,"blives",opadata=opadata,...)
if(!is.null(leconf))li[[130]] <- bsll(legend="")
li <- c(li,leconf)
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 <- opafit$label,"")){label <- NULL}
supported_position <- c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right","center")
if(!any(tolower(opafit$legend.position) %in% supported_position)){
warning(paste0(opafit$legend.position," is not a supported legend position, bottomright applied"))
opa.fit$legend.position<-"bottomright"
}
if(!is.numeric(opafit$legend.inset) || any(opafit$legend.inset<0) || any(opafit$legend.inset>1)) {
warning("legend.inset to be fractional graph width and height (0 and 1) inclusive \n default c(0,0) applied.")
opafit$legend.inset<- c(0,0)
}
# }
le$rect <- legend(
tolower(opafit$legend.position),
# "bottomright",
legend=le$legend,
title=label,
cex = opafit$legend.text.size,
inset=opafit$legend.inset,
# merge = TRUE,
plot=FALSE)$rect
le$label <- opafit$label
le$legend.text.size <- opafit$legend.text.size
}
le
}
bsll <- function(...){
arg <- list(...)
leline <- list(
legend= NA,
lty= NA,
lwd= NA,
pch= NA,
col= NA)
modifyList(leline,arg)
# leline <- list(
# legend= <- ifelse(is.null(arg$legend),NA,arg$legend)
# title= <- ifelse(is.null(arg$title),NA,arg$title)
# cex= <- ifelse(is.null(arg$cex),NA,arg$cex)
# bg= <- ifelse(is.null(arg$bg),NA,arg$bg)
# lty= <- ifelse(is.null(arg$lty),NA,arg$lty)
# lwd= <- ifelse(is.null(arg$lwd),NA,arg$lwd)
# pch= <- ifelse(is.null(arg$pch),NA,arg$pch)
# col= <- ifelse(is.null(arg$col),NA,arg$col)
}
## It is believed that the original use of ... here caused warnings upon check --as-cran
##Blifestring <- function(B,blicon,signif,...){
Blifestring <- function(B,blicon,signif,args){
# This functions creates a string for displaying the B-lives in the plot's
# legend. missing input data result in an "NA". For example, the output
# string could look like:
# "B10 = 9.86 | 50.13 | 103.4"
# or
# "B1 = 9.86 | 50.13 | NA"
si <- function(number)
if(!is.null(number))signif(number,signif)
else NA
# shorthand writing of the signif() function
## qfun <- function(B,...){
qfun <- function(B){
## fit params are now passed in as a list object, args
## args <- as.list(unlist(...))
ret <- NULL
if(!is.null(args$beta) && !is.null(args$eta)){
# the fit type was weibull
ret <- qweibull(B,args$beta,args$eta)
if(!is.null(args$t0)){
# the fit type was weibull3p
ret <- ret+args$t0
}
}
if(!is.null(args$meanlog) && !is.null(args$sdlog)){
# the fit type was lognormal
ret <- qlnorm(B,args$meanlog,args$sdlog)
}
if(!is.null(args$rate)){
# the fit type was exponential
ret <- qexp(B,args$rate)
}
ret
}
id <- function(x,y)isTRUE(all.equal(x,y))
c1 <- is.null(blicon$bounds) || is.null(blicon$bounds$Lower)
## use of subset with select argument upon check --as-cran
## causes Note: 'no visible binding for global variable'
## for the Lower and Upper column names
# if(!c1) lo <- si(subset(blicon$bounds,
# sapply(blicon$bounds$unrel,id,B),select=Lower))
if(!c1) lo <- si(blicon$bounds[
sapply(blicon$bounds$unrel,id,B),which(colnames(blicon$bounds)=="Lower")])
c2 <- is.null(blicon$bounds) || is.null(blicon$bounds$Upper)
if(!c2) up <- si(blicon$bounds[
sapply(blicon$bounds$unrel,id,B),which(colnames(blicon$bounds)=="Upper")])
ret <- paste(sep = ""," B",signif(100*B)," = ",
ifelse(c1,
"NA",lo),
## " | ",si(qfun(B,...)),
" | ",si(qfun(B)),
" | ",ifelse(c2,
"NA",up))
ret
}
Try the WeibullR package in your browser
Any scripts or data that you put into this service are public.
WeibullR documentation built on June 26, 2022, 1:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions Blifestring bsll buildSingleFitLegend buildSingleDataLegend legendConf
legendConf <- function(fit,conftype,opadata,...){
if(!is.null(fit)){
if(!is.null(fit$options))
opafit <- modifyList(opadata,fit$options)
opafit <- modifyList(opafit,list(...))
if(identical(tolower(conftype),"blives")){
if(!is.null(fit$conf)){
for.each.blicon <- function(blicon){
if(!is.null(blicon$options)){
opaconf <- modifyList(opafit,blicon$options)
}else{opaconf <- opafit}
if(opaconf$in.legend){
# TODO: correct usage of this logical value?
li <- list()
li[[1]] <- bsll(legend=paste0("CI bounds, type = ",
ifelse(is.null(blicon$type),"NA",
paste0("\"",blicon$type,"\""))),
col=opaconf$col,lwd=opaconf$lwd,lty=opaconf$lty)
li[[2]] <- bsll(legend=paste0(" CI = ",
ifelse(is.null(blicon$ci),"NA",
paste0(signif(blicon$ci*100,4)," [%]")),
ifelse(is.null(blicon$dof),"",
paste0(", dof = ",blicon$dof)),
ifelse(is.null(blicon$S),"",
paste0(", S = ",blicon$S))))
if(opaconf$in.legend.blives){
ssCL<- signif((1-(1-blicon$ci)/2)*100,4)
li[[3]] <- bsll(legend=paste0("B-life ssCL = ",
ifelse(is.null(blicon$ci),"NA",
paste0(ssCL," [%]"))))
## keep the params in a list object to pass in as args to Blifestring
## params <- unlist(list(beta=fit$beta,eta=fit$eta,t0=fit$t0,
## meanlog=fit$meanlog,sdlog=fit$sdlog,rate=fit$rate))
params <- list(beta=fit$beta,eta=fit$eta,t0=fit$t0,
meanlog=fit$meanlog,sdlog=fit$sdlog,rate=fit$rate)
if(is.null(bl <- blicon$blife.pts))bl <- opaconf$blife.pts
fu <- function(bl){
bsll(legend=Blifestring(bl,blicon,opafit$signif,params))
}
c(li,lapply(bl,fu))
}else(li)
}else NULL
}
#mtrace(for.each.blicon)
unlist(lapply(fit$conf,for.each.blicon),FALSE)
# TODO: replace by do.call ?
}else{NULL}
}
}else{NULL}
}
buildSingleDataLegend <- function(x,opadata,...){
arg <- list(...)
si <- function(number)signif(number,opadata$signif)
li <- list()
if(opadata$in.legend){
li[[10]] <- bsll(legend=paste0("ranks = ",opadata$pp[1]),
col=opadata$col,pch=opadata$pch,lwd=opadata$lwd.points)
if(is.null(x$data$dlines)) {
li[[15]] <- bsll(legend=paste0("n (fail | cens.) = ",x$n,
" (",x$fail," | ",x$cens,")"))
}else{
li[[15]] <- bsll(legend=paste0("n (f | s | d | i) = ",x$n,
" (",x$fail," | ",x$cens," | ",x$discovery," | ",x$interval,")"))
}
}
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}
supported_position <- c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", "center")
if(!any(tolower(opadata$legend.position) %in% supported_position)){
warning(paste0(opadata$legend.position," is not a supported legend position, bottomright applied"))
opa.data$legend.position<-"bottomright"
}
if(!is.numeric(opadata$legend.inset) || any(opadata$legend.inset<0) || any(opadata$legend.inset>1)) {
warning("legend.inset to be fractional graph width and height (0 and 1) inclusive \n
default c(0,0) applied.")
opadata$legend.inset<- c(0,0)
}
le$rect <- legend(
tolower(opadata$legend.position),
# "bottomright",
inset=opadata$legend.inset,
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
# le$legend.text.width <- opadata$legend.text.width
le
}
buildSingleFitLegend <- function(fit,opadata,...){
arg <- list(...)
if(!is.null(fit$options)){
opafit <- modifyList(opadata,fit$options)
}else{opafit <- opadata}
opafit <- modifyList(opafit,list(...))
t0 <- NULL
le <- NULL
if(opafit$is.plot.legend){
## removing threshold effects, when needed t0 is fit$t0 fit$modified indicates data modification by t0
#if(is.logical(opafit$threshold))if(opafit$threshold){
# if(is.logical(opadata$threshold)){if(opadata$threshold)
# warning("opafit$threshold and opadata$threshold are logical values but numeric values were expected. Proceeding...")
# }else{
# reuse the t0 value from the data level
# t0 <- opadata$threshold
# }
#}
#if(is.numeric(opafit$threshold))t0 <- opafit$threshold
si <- function(number)signif(number,opafit$signif)
# shorter writing form for signif()
li <- list()
if(opadata$in.legend){
modstr<-""
if(fit$modified) modstr<- "*t0 mod* "
li[[10]] <- bsll(legend=paste0(modstr,"ranks = ",opafit$pp[1]),
col=opadata$col,pch=opadata$pch,lwd=opadata$lwd.points)
## I don't understand why this becomes necessary with a fit
## Data types should be defined on entry with wblr object creation
## This is one reason for the redundant placement of data types in each fit
if((fit$discovery+fit$interval)==0) {
li[[15]] <- bsll(legend=paste0("n (fail | cens.) = ",fit$n,
" (",fit$fail," | ",fit$cens,")"))
}else{
li[[15]] <- bsll(legend=paste0("n (f | s | d | i) = ",fit$n,
" (",fit$fail," | ",fit$cens," | ",fit$discovery," | ",fit$interval,")"))
}
}
if(opafit$in.legend){
li[[20]] <- bsll(legend = paste0(fit$options$dist," (",
paste0(fit$options$method.fit,collapse=", "),")"),
col=opafit$col,lwd=opafit$lwd,lty=opafit$lty)
li[[30]] <- bsll(legend=ifelse(is.null(fit$rate),NA,
paste0("rate = ",si(fit$rate))))
li[[40]] <- bsll(legend=ifelse(is.null(fit$meanlog),NA,
paste0("mean(log) = ",si(exp(fit$meanlog))," (",
si(fit$meanlog),")")))
li[[50]] <- bsll(legend=ifelse(is.null(fit$sdlog),NA,
paste0("sd(log) = ",si(exp(fit$sdlog))," (",
si(fit$sdlog),")")))
li[[60]] <- bsll(legend=ifelse(is.null(fit$beta),NA,
paste0("beta = ",si(fit$beta))))
li[[70]] <- bsll(legend=ifelse(is.null(fit$eta),NA,
paste0("eta = ",si(fit$eta))))
li[[80]] <- bsll(legend=ifelse(is.null(fit$t0),NA,
paste0("t0 = ",si(fit$t0))))
if(!is.null(fit$gof) && opafit$in.legend.gof){
if(!is.null(fit$gof$r2)){
if(!is.null(fit$gof$ccc2)){
li[[100]] <- bsll(legend=paste0("r^2 | CCC^2 = ",
si(fit$gof$r2)," | ",si(fit$gof$ccc2),
ifelse(fit$gof$r2>=fit$gof$ccc2," (good)"," (BAD)")))
}else{
li[[100]] <- bsll(legend=paste0("r^2 = ",si(fit$gof$r2)))
}
}
if(!is.null(fit$gof$loglik)){
li[[110]] <- bsll(legend=paste0("loglik = ",si(fit$gof$loglik)))
}
li[[120]] <- bsll(
legend=ifelse(is.null(fit$gof$prr),NA,
#paste0("prr = ",si(fit$gof$prr)," (S=",
#ifelse(is.null(fit$gof$S),"NA",fit$gof$S),")")))
paste0("prr = ",si(fit$gof$prr)," by corr.")
)
)
}
}
#leconfpos <- length(na.omit(unlist(li))) + 1
# where displaying confidence info begins
leconf <- legendConf(fit,"blives",opadata=opadata,...)
if(!is.null(leconf))li[[130]] <- bsll(legend="")
li <- c(li,leconf)
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 <- opafit$label,"")){label <- NULL}
supported_position <- c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right","center")
if(!any(tolower(opafit$legend.position) %in% supported_position)){
warning(paste0(opafit$legend.position," is not a supported legend position, bottomright applied"))
opa.fit$legend.position<-"bottomright"
}
if(!is.numeric(opafit$legend.inset) || any(opafit$legend.inset<0) || any(opafit$legend.inset>1)) {
warning("legend.inset to be fractional graph width and height (0 and 1) inclusive \n default c(0,0) applied.")
opafit$legend.inset<- c(0,0)
}
# }
le$rect <- legend(
tolower(opafit$legend.position),
# "bottomright",
legend=le$legend,
title=label,
cex = opafit$legend.text.size,
inset=opafit$legend.inset,
# merge = TRUE,
plot=FALSE)$rect
le$label <- opafit$label
le$legend.text.size <- opafit$legend.text.size
}
le
}
bsll <- function(...){
arg <- list(...)
leline <- list(
legend= NA,
lty= NA,
lwd= NA,
pch= NA,
col= NA)
modifyList(leline,arg)
# leline <- list(
# legend= <- ifelse(is.null(arg$legend),NA,arg$legend)
# title= <- ifelse(is.null(arg$title),NA,arg$title)
# cex= <- ifelse(is.null(arg$cex),NA,arg$cex)
# bg= <- ifelse(is.null(arg$bg),NA,arg$bg)
# lty= <- ifelse(is.null(arg$lty),NA,arg$lty)
# lwd= <- ifelse(is.null(arg$lwd),NA,arg$lwd)
# pch= <- ifelse(is.null(arg$pch),NA,arg$pch)
# col= <- ifelse(is.null(arg$col),NA,arg$col)
}
## It is believed that the original use of ... here caused warnings upon check --as-cran
##Blifestring <- function(B,blicon,signif,...){
Blifestring <- function(B,blicon,signif,args){
# This functions creates a string for displaying the B-lives in the plot's
# legend. missing input data result in an "NA". For example, the output
# string could look like:
# "B10 = 9.86 | 50.13 | 103.4"
# or
# "B1 = 9.86 | 50.13 | NA"
si <- function(number)
if(!is.null(number))signif(number,signif)
else NA
# shorthand writing of the signif() function
## qfun <- function(B,...){
qfun <- function(B){
## fit params are now passed in as a list object, args
## args <- as.list(unlist(...))
ret <- NULL
if(!is.null(args$beta) && !is.null(args$eta)){
# the fit type was weibull
ret <- qweibull(B,args$beta,args$eta)
if(!is.null(args$t0)){
# the fit type was weibull3p
ret <- ret+args$t0
}
}
if(!is.null(args$meanlog) && !is.null(args$sdlog)){
# the fit type was lognormal
ret <- qlnorm(B,args$meanlog,args$sdlog)
}
if(!is.null(args$rate)){
# the fit type was exponential
ret <- qexp(B,args$rate)
}
ret
}
id <- function(x,y)isTRUE(all.equal(x,y))
c1 <- is.null(blicon$bounds) || is.null(blicon$bounds$Lower)
## use of subset with select argument upon check --as-cran
## causes Note: 'no visible binding for global variable'
## for the Lower and Upper column names
# if(!c1) lo <- si(subset(blicon$bounds,
# sapply(blicon$bounds$unrel,id,B),select=Lower))
if(!c1) lo <- si(blicon$bounds[
sapply(blicon$bounds$unrel,id,B),which(colnames(blicon$bounds)=="Lower")])
c2 <- is.null(blicon$bounds) || is.null(blicon$bounds$Upper)
if(!c2) up <- si(blicon$bounds[
sapply(blicon$bounds$unrel,id,B),which(colnames(blicon$bounds)=="Upper")])
ret <- paste(sep = ""," B",signif(100*B)," = ",
ifelse(c1,
"NA",lo),
## " | ",si(qfun(B,...)),
" | ",si(qfun(B)),
" | ",ifelse(c2,
"NA",up))
ret
}
Try the WeibullR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.