https://github.com/cran/nacopula
Tip revision: e24ab1e
Auxiliaries.R
## Copyright (C) 2010 Marius Hofert and Martin Maechler
##
## This program is free software; you can redistribute it and/or modify it under
## Foundation; either version 3 of the License, or (at your option) any later
## version.
##
## This program is distributed in the hope that it will be useful, but WITHOUT
## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
## FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
## details.
##
## You should have received a copy of the GNU General Public License along with
## this program; if not, see <http://www.gnu.org/licenses/>.

####  'interval'	 class utilities
####  =========================== these are small and simple
###   use require(package= "Intervals")	 if you want serious interval "work"
interval <- function(ch) {
## Purpose: "interval" object constructor from string  "[ a, b)", ...
## Author: Martin Maechler, Date: 16 Nov 2009
stopifnot(is.character(ch), length(ch) == 1L)
sp <- strsplit(ch, ", *")[]
if(length(sp) != 2L) stop("'ch' must contain exactly one \",\"")
L <- gsub(" +", "", sp); bL <- substr(L, 1,1)
if(!any(iL <- bL == c("(","[","]")))
R <- gsub(" +", "", sp); nR <- nchar(R); bR <- substr(R, nR,nR)
if(!any(iR <- bR == c(")","]","[")))
stop("interval specification must end with \")\",  \"]\"  or \"[\"")
new("interval", as.numeric(c(substring(L, 2), substr(R, 1, nR-1))),
open = c(which(iL) != 2, which(iR) != 2))
}

setMethod("format", "interval",
function(x, trim = TRUE, ...) {
r <- format(x@.Data, trim=trim, ...)
paste(if(x@open) "(" else "[", r,", ", r,
if(x@open) ")" else "]", sep="")
})

setMethod("show", "interval",
function(object) cat("'interval' object  ", format(object), "\n",
sep=''))

##' Summary group method: range(), min(), max(), [sum(), prod(), any(), all()] :
setMethod("Summary", signature(x = "interval", na.rm = "ANY"),
function(x, ..., na.rm) callGeneric(x@.Data, ..., na.rm=na.rm))

setMethod("%in%", signature(x = "numeric", table = "interval"),
function(x, table) {
op <- table@open
(if(op) `<` else `<=`)(table, x) &
(if(op) `<` else `<=`)(x, table)
})