#######################################
### Hook functions for package start-up
#######################################
gpclibCheck <- function (fatal = TRUE)
{
gpclibOK <- surveillance.options("gpclib")
if (!gpclibOK && fatal) {
message("Note: The gpclib license is accepted by ",
sQuote("surveillance.options(gpclib=TRUE)"), ".")
stop("acceptance of the gpclib license is required")
}
gpclibOK
}
.onLoad <- function (libname, pkgname)
{
## initialize options
reset.surveillance.options()
}
.onAttach <- function (libname, pkgname)
{
## Startup message
VERSION <- packageVersion(pkgname, lib.loc=libname)
packageStartupMessage("This is ", pkgname, " ", VERSION, ". ",
"For overview type ",
sQuote(paste0("help(", pkgname, ")")), ".")
## decide if we should run all examples (some take a few seconds)
allExamples <- if (interactive()) {
TRUE
} else { # R CMD check
## only do all examples if a specific environment variable is set
## (to any value different from "")
nzchar(Sys.getenv("_R_SURVEILLANCE_ALL_EXAMPLES_"))
## CAVE: testing for _R_CHECK_TIMINGS_ as in surveillance < 1.9-1
## won't necessarily skip long examples for daily checks on CRAN (see
## https://stat.ethz.ch/pipermail/r-devel/2012-September/064812.html
## ). For instance, the daily Windows checks run without timings.
}
surveillance.options(allExamples = allExamples)
}
###########################
### Little helper functions
###########################
### checking if x is scalar, i.e. a numeric vector of length 1.
isScalar <- function (x) {
length(x) == 1L && is.vector(x, mode = "numeric")
}
### _c_onditional lapply, which only uses lapply() if X really is a list object
### and otherwise applies FUN to X. The result is always a list (of length 1 in
### the latter case). Used for neOffset in hhh4 models.
clapply <- function (X, FUN, ...)
{
if (is.list(X)) lapply(X, FUN, ...) else list(FUN(X, ...))
}
### pretty p-value formatting
formatPval <- function (pv, eps = 1e-4, scientific = FALSE, ...)
{
format1 <- function (p)
format.pval(p, digits = if (p < 10*eps) 1 else 2, eps = eps,
nsmall = 2, scientific = scientific, ...)
vapply(X = pv, FUN = format1, FUN.VALUE = "", USE.NAMES = TRUE)
}
### determines multiplicities in a matrix (or data frame)
### and returns unique rows with appended column of counts
countunique <- function (x) unique(cbind(x, COUNT = multiplicity(x)))
### generate a color vector (via the colorspace package)
hcl.colors <- function (ncolors=100, use.color=TRUE)
{
GYR <- if (requireNamespace("colorspace", quietly=TRUE)) {
## the Zeil-ice colors
colorspace::heat_hcl(ncolors, h=c(0,120),
c=if (use.color) c(90,30) else c(0,0),
l=c(50,90), power=c(0.75, 1.2))
} else {
if (use.color) heat.colors(ncolors) else grey.colors(ncolors)
}
return(rev(GYR))
}
###############################################################
### backwards-compatibility for old class name "ah4" (<= 1.7-0)
###############################################################
local({
methods17 <- c("print", "summary", "print.summary", "terms", "logLik",
"coef", "fixef", "ranef", "confint", "predict",
"update", "plot", "simulate")
for (generic in methods17) {
methodname <- paste(generic, "hhh4", sep=".")
method <- get(methodname)
## mark ah4-method as deprecated (as of next major release)
## body(method) <- as.call(append(
## as.list(body(method)),
## substitute(
## .Deprecated(new,
## msg=c(
## "Since surveillance 1.8-0, hhh4()-results are of",
## " class \"hhh4\" instead of \"ah4\".",
## "\nOld \"ah4\"-methods will be removed.")),
## list(new=methodname)),
## after=1L))
assign(paste(generic, "ah4", sep="."), method, pos=parent.frame(2L))
}
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.