"add.lmomco.axis" <-
function(side=1, twoside=FALSE, twoside.suppress.labels=FALSE,
side.type=c("NPP", "RI", "SNV"), otherside.type=c("NA", "RI", "SNV", "NPP"),
alt.lab=NA, alt.other.lab=NA, npp.as.aep=FALSE, case=c("upper", "lower"),
NPP.control=NULL, RI.control=NULL, SNV.control=NULL, ...) {
case <- match.arg(case)
other.side <- switch(as.character(side), "1"=3, "2"=4, "3"=1, "4"=1)
side.type <- match.arg(side.type)
otherside.type <- match.arg(otherside.type)
if(otherside.type == "NA") otherside.type <- NA
if(twoside & ! is.na(otherside.type)) twoside <- FALSE
lims <- par()$usr; #print(lims)
ifelse(side == 1 | side == 3, lims <- lims[1:2], lims <- lims[3:4])
#print(lims)
lims <- pnorm(lims)
#print(lims)
"my.nonexceeds" <- function(minors=FALSE) {
if(minors) {
FF <- c(0.55, 0.65, 0.75, 0.825, 0.850, 0.875,
0.91, 0.92, 0.93, 0.94, 0.96, 0.97,
0.9925, 0.996, 0.997, 0.9996, 0.9997, 0.99996, 0.99997)
FF <- c(sort(1-FF), FF)
FF <- FF[FF >= lims[1]]; FF <- FF[FF <= lims[2]]
FF <- unique(c(lims[1],FF,lims[2])) # the real nature of the nums, this is backup
return(FF)
} else {
FF <- c(0.6, 0.7, 0.8, 0.9, 0.95, 0.98, 0.99, 0.995, 0.998, 0.999,
0.9995, 0.9998, 0.9999, 0.99995, 0.99998, 0.99999)
FF <- c(sort(1-FF), 0.5, FF)
#print(FF)
FF <- FF[FF >= lims[1]]; FF <- FF[FF <= lims[2]]
#print(FF)
FF <- unique(c(lims[1],FF,lims[2])) # the real nature of the nums, this is backup
return(FF)
}
}
if(is.null(NPP.control)) {
txt.npp <- ifelse(case == "upper", "NONEXCEEDANCE PROBABILITY", "Nonexceedance probability")
txt.epp <- ifelse(case == "upper", "EXCEEDANCE PROBABILITY", "Exceedance probability")
the.label <- ifelse(is.na(alt.lab), txt.npp, alt.lab)
the.other.label <- ifelse(is.na(alt.other.lab), txt.epp, alt.other.lab)
NPP.control <- list(label=the.label,
other.label=the.other.label,
probs=my.nonexceeds(minors=TRUE),
probs.label=my.nonexceeds(minors=FALSE),
digits=3, line=3, as.exceed=FALSE)
}
if(is.null(RI.control)) {
txt.ri <- ifelse(case == "upper", "RECURRENCE INTERVAL, IN YEARS", "Recurrence interval, in years")
the.label <- ifelse(is.na(alt.lab), txt.ri, alt.lab)
RI.control <- list(label=the.label,
Tyear=c(2, 5, 10, 25, 50, 100, 200, 500), line=2)
}
if(is.null(SNV.control)) {
txt.snv <- ifelse(case == "upper", "STANDARD NORMAL VARIATE", "Standard normal variate")
the.label <- ifelse(is.na(alt.lab), txt.snv, alt.lab)
SNV.control <- list(label=the.label,
begin=-5, end=5, by=0.5, line=2)
}
NPPf <- function(side, other.side) {
dots <- list(...)
tcl <- ifelse("tcl" %in% names(dots), dots$tcl, par()$tcl)
NPP <- NPP.control$probs; NPP.lab <- NPP.control$probs.lab
if(NPP.control$as.exceed) {
the.true.NPP.lab <- 1 - NPP.lab
} else {
the.true.NPP.lab <- NPP.lab
}
qNPP <- qnorm(NPP); qNPP.lab <- qnorm(NPP.lab)
if(npp.as.aep) {
NPP.lab <- format(1-the.true.NPP.lab, nsmall=NPP.control$digits)
} else {
NPP.lab <- format( the.true.NPP.lab, nsmall=NPP.control$digits)
}
# By placing tcl last (after ...), its value will trump that potentially in ...
Axis(qNPP, at=qNPP, labels=NA, side=side, ..., tcl=0.8*tcl)
Axis(qNPP.lab, at=qNPP.lab, labels=NPP.lab, side=side, ..., tcl=1.3*tcl)
if(npp.as.aep) {
mtext(NPP.control$other.label, line=NPP.control$line, side=side)
} else {
mtext(NPP.control$label, line=NPP.control$line, side=side)
}
if(twoside) {
Axis(qNPP, at=qNPP, labels=NA, side=other.side, ..., tcl=0.8*tcl)
if(twoside.suppress.labels) {
Axis(qNPP.lab, at=qNPP.lab, labels=NA, side=other.side, ..., tcl=1.3*tcl)
} else {
Axis(qNPP.lab, at=qNPP.lab, labels=NPP.lab, side=other.side, ..., tcl=1.3*tcl)
}
}
}
RIf <- function(side, other.side) {
F <- 1 - 1/RI.control$Tyear; qF <- qnorm(F); labF <- RI.control$Tyear
Axis(qF, at=qF, labels=labF, side=side, ...)
if(twoside) {
Axis(at=qF, labels=NA, side=other.side, ...)
}
mtext(RI.control$label, line=RI.control$line, side=side)
}
SNVf <- function(side, other.side) {
SNV <- NULL
try( SNV <- seq(SNV.control$begin, SNV.control$end, by=SNV.control$by) )
if(is.null(SNV)) {
warning("Poorly constructed SNV.control, trapping, and using alternative")
SNV <- seq(-5, 5, by=0.5)
}
Axis(SNV, at=SNV, side=side, ...)
mtext(SNV.control$label, line=SNV.control$line, side=side)
if(twoside) {
Axis(SNV, at=SNV, side=other.side, ...)
}
}
NULLf <- function() { return("no axis function made") }
primary.axis <- switch(side.type, NPP=NPPf, RI=RIf, SNV=SNVf, NULLf)
primary.axis(side, other.side)
if(! is.na(otherside.type)) {
secondary.axis <- switch(otherside.type, NPP=NPPf, RI=RIf, SNV=SNVf, NULLf)
secondary.axis(other.side, side)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.