Nothing
# Functions for boolean vectors
# (c) 2008-2017 Jens Oehlschägel
# Licence: GPL2
# Provided 'as is', use at your own risk
# source("C:/mwp/eanalysis/bit/R/bit.R")
# Configuration: set this to 32L or 64L and keep in sync with BITS in bit.c
#' @rdname bit_init
#' @export
.BITS <- 32L
#' Initializing bit masks
#'
#' Functions to allocate (and de-allocate) bit masks
#'
#' The C-code operates with bit masks. The memory for these is allocated
#' dynamically. \code{bit_init} is called by \code{\link{.First.lib}} and
#' \code{bit_done} is called by \code{\link{.Last.lib}}. You don't need to
#' care about these under normal circumstances.
#'
#' @return NULL
#' @author Jens Oehlschlägel
#' @seealso \code{\link{bit}}
#' @keywords classes logic
#' @examples
#'
#' bit_done()
#' bit_init()
#'
#' @export
bit_init <- function()
.Call(C_R_bit_init, .BITS)
#' @rdname bit_init
#' @export
bit_done <- function()
.Call(C_R_bit_done)
#' Create empty bit vector
#'
#' Bit vectors are a boolean type wihout \code{NA} that requires by factor 32 less RAM than \code{\link{logical}}.
#' For details on usage see the \href{../doc/bit-usage.html}{usage-vignette} and for details on performance see \href{../doc/bit-performance.html}{performance-vignette}
#'
#' @param length length in bits
#' @return \code{bit} returns a vector of integer sufficiently long to store 'length' bits
#' @seealso \code{\link{booltype}}, \code{\link{bitwhich}}, \code{\link{logical}}
#' @keywords classes logic
#' @examples
#' bit(12)
#' !bit(12)
#' str(bit(128))
#' @export
bit <- function(length=0L){
length <- as.integer(length)
if (length %% .BITS)
n <- length %/% .BITS + 1L
else
n <- length %/% .BITS
if (.BITS==64L)
x <- integer(2L*n)
else
x <- integer(n)
#physical(x) <- list(vmode="boolean")
#virtual(x) <- list(Length=length)
#class(x) <- "bit"
# tuning
p <- list()
v <- list()
attributes(p) <- list(vmode="boolean", class="physical")
attributes(v) <- list(Length=length, class="virtual")
setattributes(x, list(physical=p, virtual=v, class=c("booltype","bit")))
x
}
#' Print method for bit
#'
#' @param x a bit vector
#' @param ... passed to print
#' @return a character vector showing first and last elements of the bit vector
#' @examples
#' print(bit(120))
#' @export
print.bit <- function(x, ...){
n <- length(x)
cat("bit length=", n, " occupying only ", length(unclass(x)), " int32\n", sep="")
if (n>16){
y <- c(x[1:8], "..", x[(n-7L):n])
names(y) <- c(1:8, "", (n-7L):n)
print(y, quote=FALSE, ...)
}else if(n){
y <- c(x[])
names(y) <- c(1:n)
print(y, quote=FALSE, ...)
}
}
#' Coerce bit to character
#'
#' @param x a \code{\link{bit}} vector
#' @param ... ignored
#' @return a character vector of zeroes and ones
#' @examples
#' as.character(bit(12))
#' @export
as.character.bit <- function(x, ...){
c("0","1")[1+as.logical(x)]
}
#' Str method for bit
#'
#' To actually view the internal structure use \code{str(unclass(bit))}
#'
#' @inheritParams utils::str
#' @return \code{\link{invisible}}
#' @importFrom utils strOptions
#' @examples
#' str(bit(120))
#' @export
str.bit <- function(object
, vec.len = strO$vec.len
, give.head = TRUE
, give.length = give.head
, ...
)
{
strO <- strOptions()
vec.len <- 8*vec.len
n <- length(object)
if (n>vec.len)
object <- as.bit(object[seq_len(vec.len)])
cat(if (give.head)paste("bit ", if (give.length && n>1) paste(" [1:",n,"] ",sep=""), sep=""), paste(as.character(object), collapse=" ")," \n", sep="")
invisible()
}
#' Coerce bitwhich to character
#'
#' @param x a \code{\link{bitwhich}} vector
#' @param ... ignored
#' @return a character vector of zeroes and ones
#' @examples
#' as.character(bitwhich(12))
#' @export
as.character.bitwhich <- function(x, ...)c("0","1")[1+as.logical(x)]
#' Str method for bitwhich
#'
#' To actually view the internal structure use \code{str(unclass(bitwhich))}
#'
#' @inheritParams utils::str
#' @return \code{\link{invisible}}
#' @examples
#' str(bitwhich(120))
#' @export
str.bitwhich <- function(object
, vec.len = strO$vec.len
, give.head = TRUE
, give.length = give.head
, ...
){
strO <- strOptions()
vec.len <- 8*vec.len
n <- length(object)
if (n>vec.len)
object <- as.bitwhich(object[seq_len(vec.len)])
cat(if (give.head)paste("bitwhich ", if (give.length && n>1) paste(" [1:",n,"] ",sep=""), sep=""), paste(as.character(object), collapse=" ")," \n", sep="")
invisible()
}
#' Create bitwhich vector (skewed boolean)
#'
#' A bitwhich object represents a boolean filter like a \code{\link{bit}} object (NAs are not allowed)
#' but uses a sparse representation suitable for very skewed (asymmetric) selections.
#' Three extreme cases are represented with logical values, no length via logical(),
#' all TRUE with TRUE and all FALSE with FALSE. All other selections are represented with
#' positive or negative integers, whatever is shorter.
#' This needs less RAM compared to \code{\link{logical}} (and often less than \code{\link{bit}} or \code{\link[=as.which]{which}}).
#' Logical operations are fast if the selection is asymetric (only few or almost all selected).
#'
#' @param maxindex length of the vector
#' @param x Information about which positions are FALSE or TRUE: either \code{logical()} or \code{TRUE} or \code{FALSE} or a integer vector of positive or of negative subscripts.
#' @param xempty what to assume about parameter \code{x} if \code{x=integer(0)}, typically \code{TRUE} or \code{FALSE}.
#' @param poslength tuning: \code{poslength} is calculated automatically, you can give \code{poslength} explicitely, in this case it must be correct and \code{x} must be sorted and not have duplicates.
#' @param is.unsorted tuning: FALSE implies that \code{x} is already sorted and sorting is skipped
#' @param has.dup tuning: FALSE implies that \code{x} has no duplicates
#' @return an object of class 'bitwhich' carrying two attributes
#' \describe{
#' \item{maxindex}{ see above }
#' \item{poslength}{ see above }
#' }
#' @seealso \code{\link{bitwhich_representation}}, \code{\link{as.bitwhich}}, \code{\link{bit}}
#' @examples
#' bitwhich()
#' bitwhich(12)
#' bitwhich(12, x=TRUE)
#' bitwhich(12, x=3)
#' bitwhich(12, x=-3)
#' bitwhich(12, x=integer())
#' bitwhich(12, x=integer(), xempty=TRUE)
#' @export
bitwhich <- function(maxindex=0L, x=NULL, xempty=FALSE, poslength=NULL, is.unsorted=TRUE, has.dup=TRUE){
maxindex <- as.integer(maxindex)
if (maxindex==0L){
if ((!is.null(poslength) && poslength) || (length(x) && (!is.logical(x) || x[[1]]==TRUE)))
stop("maxindex=0 given with poslength or x")
poslength <- 0L
ret <- logical()
}else{
stopifnot(maxindex>0L)
if (length(x)){
if (is.logical(x)){
if (length(x)!=1L || is.na(x)){
stop("logical x should be scalar FALSE or TRUE")
}else if (x){
if (is.null(poslength))
poslength <- maxindex
else if (poslength!=maxindex)
stop("x==TRUE implies poslength==maxindex")
ret <- copy_vector(TRUE)
}else{
if (is.null(poslength))
poslength <- 0L
else if (poslength!=0L)
stop("x==FALSE implies poslength==0")
ret <- copy_vector(FALSE)
}
}else{
x <- as.integer(x)
if (is.null(poslength)){
ret <- range_nanozero(x)
r <- getsetattr(ret, "range_na", NULL)
if (r[3]>0L)
stop("NA positions not allowed (neither positive nor negative)")
if (r[1]<0L){
if (r[2]>0L)
stop("mixed negative and positive subscripts not allowed")
if (-r[1] > maxindex)
stop("index value outside -maxindex..-1")
}else{
if (r[2] > maxindex)
stop("index value outside 1..maxindex")
}
if (is.unsorted)
ret <- bit_sort_unique(ret, na.last=NA, range_na=r)
else if (has.dup)
ret <- bit_unique(ret, na.rm = FALSE, range_na=r)
if (ret[1]<0){
poslength <- maxindex - length(ret)
if (poslength){
if (poslength <= maxindex%/%2L)
ret <- merge_rangediff(c(1L,maxindex), ret, revx=FALSE, revy=TRUE)
}else{
ret <- copy_vector(FALSE)
}
}else{
poslength <- length(ret)
if (poslength < maxindex){
if (poslength > maxindex%/%2L)
ret <- merge_rangediff(c(1L,maxindex), ret, revx=TRUE, revy=TRUE)
}else{
ret <- copy_vector(TRUE)
}
}
}else{
poslength <- as.integer(poslength)
if (poslength==0L)
ret <- copy_vector(FALSE)
else if (poslength==maxindex)
ret <- copy_vector(TRUE)
else{
if (length(x) > 2 && x[1] >= x[2])
stop("x is not sorted unique")
if ( x[1]<0L ){
if ( poslength != maxindex - length(x) )
stop("wrong poslength")
if (poslength <= maxindex%/%2L)
ret <- merge_rangediff(c(1L,maxindex), x, revx=FALSE, revy=TRUE)
else
ret <- copy_vector(x)
}else{
if ( poslength != length(x) )
stop("wrong poslength")
if (poslength > maxindex%/%2L)
ret <- merge_rangediff(c(1L,maxindex), x, revx=TRUE, revy=TRUE)
else
ret <- copy_vector(x)
}
}
}
}
}else{
if (is.null(poslength)){
if (!is.logical(xempty) || length(xempty)!=1 || is.na(xempty))
stop("xempty must be FALSE or TRUE")
if (xempty)
poslength <- maxindex
else
poslength <- 0L
ret <- copy_vector(xempty)
}else{
poslength <- as.integer(poslength)
if (poslength==0)
ret <- copy_vector(FALSE)
else if (poslength==maxindex)
ret <- copy_vector(TRUE)
else
stop("need x with extreme poslength")
}
}
}
setattributes(ret, list("maxindex" = maxindex, "poslength" = poslength, "class" = c("booltype","bitwhich")))
ret
}
#' Diagnose representation of bitwhich
#'
#' @param x a \code{\link{bitwhich}} object
#' @return a scalar, one of \code{logical()}, \code{FALSE}, \code{TRUE}, \code{-1} or \code{1}
#' @examples
#' bitwhich_representation(bitwhich())
#' bitwhich_representation(bitwhich(12,FALSE))
#' bitwhich_representation(bitwhich(12,TRUE))
#' bitwhich_representation(bitwhich(12, -3))
#' bitwhich_representation(bitwhich(12, 3))
#' @export
bitwhich_representation <- function(x)
{
.Call(C_R_bitwhich_representation, x)
}
#' Print method for bitwhich
#'
#' @param x a \code{\link{bitwhich}} object
#' @param ... ignored
#' @export
print.bitwhich <- function(x, ...){
n <- length(x)
cat("bitwhich: ", sum(x), "/", n, " occupying only ", length(unclass(x)), " int32 in ", bitwhich_representation(x), " representation\n", sep="")
if (n>16){
y <- c(x[1:8], "..", x[(n-7L):n])
names(y) <- c(1:8, "", (n-7L):n)
print(y, quote=FALSE, ...)
}else if(n){
y <- c(x[])
names(y) <- c(1:n)
print(y, quote=FALSE, ...)
}
}
#' Boolean types
#'
#' The \code{\link{ordered}} factor \code{booltypes} ranks the boolean types.
#'
#' There are currently six boolean types, \code{booltypes} is an \code{\link{ordered}} vector with the following ordinal \code{\link{levels}} \describe{
#' \item{nobool}{non-boolean types}
#' \item{\code{\link{logical}}}{for representing any boolean data including \code{NA} }
#' \item{\code{\link{bit}}}{for representing dense boolean data }
#' \item{\code{\link{bitwhich}}}{for representing sparse (skewed) boolean data }
#' \item{\code{\link{which}}}{for representing sparse boolean data with few \code{TRUE}}
## \item{\code{\link[ff]{hi}}}{hybrid-indexing, implemented in package \code{\link[ff]{ff}} }
#' \item{\code{\link{ri}}}{range-indexing, for representing sparse boolean data with a single range of \code{TRUE} }
#' }
#' \code{booltypes} has a \code{\link{names}} attribute such that elements can be selected by name.
#'
#' @note do not rely on the internal integer codes of these levels, we might add-in \code{\link[ff]{hi}} later
#' @seealso \code{\link{booltype}}, \code{\link{is.booltype}}, \code{\link{as.booltype}}
#' @export
booltypes <- c("nobool","logical","bit","bitwhich","which","ri")
booltypes <- ordered(booltypes, levels=booltypes)
names(booltypes) <- booltypes
#' Diagnosing boolean types
#'
#' Specific methods for \code{booltype} are required, where non-unary methods can combine multiple bollean types, particularly boolean binary operators.
#'
#' Function \code{booltype} returns the boolean type of its argument.
#' There are currently six boolean types, \code{booltypes} is an \code{\link{ordered}} vector with the following ordinal \code{\link{levels}} \describe{
#' \item{nobool}{non-boolean types}
#' \item{\code{\link{logical}}}{for representing any boolean data including \code{NA} }
#' \item{\code{\link{bit}}}{for representing dense boolean data }
#' \item{\code{\link{bitwhich}}}{for representing sparse (skewed) boolean data }
#' \item{\code{\link{which}}}{for representing sparse boolean data with few \code{TRUE}}
## \item{\code{\link[ff]{hi}}}{hybrid-indexing, implemented in package \code{\link[ff]{ff}} }
#' \item{\code{\link{ri}}}{range-indexing, for representing sparse boolean data with a single range of \code{TRUE} }
#' }
#' @param x an R object
#'
#' @return one scalar element of \code{\link{booltypes}} in case of 'nobool' it carries a name attribute with the data type.
#' @note do not rely on the internal integer codes of these levels, we might add-in \code{\link[ff]{hi}} later
#' @seealso \code{\link{booltypes}}, \code{\link{is.booltype}}, \code{\link{as.booltype}}
#'
#' @examples
#' unname(booltypes)
#' str(booltypes)
#' sapply(list(double(),integer(),logical(),bit(),bitwhich(),as.which(),ri(1,2,3)), booltype)
#' @export
booltype <- function(x){
if (is.ri(x))
booltypes[["ri"]]
else if (is.hi(x))
booltypes[["hi"]]
else if (is.which(x))
booltypes[["which"]]
else if (is.bitwhich(x))
booltypes[["bitwhich"]]
else if (is.bit(x))
booltypes[["bit"]]
else if (is.logical(x))
booltypes[["logical"]]
else {
ret <- booltypes[["nobool"]]
names(ret) <- typeof(x)
ret
}
}
#' Testing for boolean types
#'
#' All \code{\link{booltypes}} including \code{\link{logical}} except 'nobool' types are considered 'is.booltype'.
#'
#' @param x an R object
#'
#' @return logical scalar
#' @seealso \code{\link{booltypes}}, \code{\link{booltype}}, \code{\link{as.booltype}}
#'
#' @examples
#' sapply(list(double(),integer(),logical(),bit(),bitwhich(),as.which(),ri(1,2,3)), is.booltype)
#' @export
is.booltype <- function(x){
inherits(x, "booltype") || is.logical(x)
}
#' @describeIn is.booltype tests for \code{\link{bit}}
#' @export
is.bit <- function(x)
inherits(x, "bit")
#' @describeIn is.booltype tests for \code{\link{bitwhich}}
#' @export
is.bitwhich <- function(x)
inherits(x, "bitwhich")
#' @describeIn is.booltype tests for \code{\link[=as.which]{which}}
#' @export
is.which <- function(x)
inherits(x, "which")
#' @describeIn is.booltype tests for \code{\link[ff]{hi}}
#' @export
is.hi <- function(x)
inherits(x, "hi")
#' @describeIn is.booltype tests for \code{\link{ri}}
#' @export
is.ri <- function(x)
inherits(x, "ri")
#' @describeIn as.booltype default method for as.booltype
#' @export
as.booltype.default <- function(x, booltype="logical", ...){
bt <- match.arg(as.character(booltype), as.character(booltypes))
do.call(switch(bt
, logical = "as.logical"
, bit = "as.bit"
, bitwhich= "as.bitwhich"
, which= "as.which"
, hi= stop("not implemented for booltype hi")
, ri= "as.ri"
), c(list(x, ...)))
}
#' @describeIn as.ri method to coerce \code{\link{ri}} to \code{\link{ri}}
#' @export
as.ri.ri <- function(x, ...)x
#' @describeIn as.ri default method to coerce to \code{\link{ri}}
#' @export
as.ri.default <- function(x, ...){
r <- range.booltype(x)
n <- maxindex(x)
ri(r[[1]], r[[2]], n)
}
#' @describeIn maxindex default method for \code{maxindex}
#' @export
maxindex.default <-
function (x, ...)
{
mi <- attr(x, "maxindex")
if (is.null(mi))
NA_integer_
else mi
}
#' @describeIn maxindex default method for \code{poslength}
#' @export
poslength.default <-
function (x, ...)
{
pl <- attr(x, "poslength")
if (is.null(pl))
NA_integer_
else pl
}
#' @describeIn maxindex \code{maxindex} method for class \code{\link{logical}}
#' @export
maxindex.logical <- function(x, ...){
length(x)
}
#' @describeIn maxindex \code{poslength} method for class \code{\link{logical}}
#' @export
poslength.logical <- function(x, ...){
sum(x)
}
#' @describeIn maxindex \code{maxindex} method for class \code{\link{bit}}
#' @export
maxindex.bit <- function(x, ...){
length(x)
}
#' @describeIn maxindex \code{poslength} method for class \code{\link{bit}}
#' @export
poslength.bit <- function(x, ...)
sum(x, ...)
#' @describeIn maxindex \code{maxindex} method for class \code{\link{bitwhich}}
#' @export
maxindex.bitwhich <- function(x, ...)
length(x, ...)
#' @describeIn maxindex \code{poslength} method for class \code{\link{bitwhich}}
#' @export
poslength.bitwhich <- function(x, ...)
sum(x, ...)
#' @describeIn maxindex \code{maxindex} method for class \code{\link[=as.which]{which}}
#' @export
maxindex.which <- function(x, ...){
attr(x, "maxindex")
}
#' @describeIn maxindex \code{poslength} method for class \code{\link[=as.which]{which}}
#' @export
poslength.which <- function(x, ...){
length(x)
}
#' @describeIn maxindex \code{maxindex} method for class \code{\link{ri}}
#' @export
maxindex.ri <- function(x, ...){
x[[3]]
}
#' @describeIn maxindex \code{poslength} method for class \code{\link{ri}}
#' @export
poslength.ri <- function(x, ...){
x[[2]] - x[[1]] + 1L
}
#' Getting and setting length of bit, bitwhich and ri objects
#'
#' Query the number of bits in a \code{\link{bit}} vector or change the number
#' of bits in a bit vector. \cr Query the number of bits in a
#' \code{\link{bitwhich}} vector or change the number of bits in a bit vector.
#' \cr
#'
#' NOTE that the length does NOT reflect the number of selected (\code{TRUE})
#' bits, it reflects the sum of both, \code{TRUE} and \code{FALSE} bits.
#' Increasing the length of a \code{\link{bit}} object will set new bits to
#' \code{FALSE}. The behaviour of increasing the length of a
#' \code{\link{bitwhich}} object is different and depends on the content of the
#' object: \itemize{
#' \item TRUE -- all included, new bits are set to \code{TRUE}
#' \item positive integers -- some included, new bits are set to \code{FALSE}
#' \item negative integers -- some excluded, new bits are set to \code{TRUE}
#' \item FALSE -- all excluded:, new bits are set to \code{FALSE} } Decreasing the
#' length of bit or bitwhich removes any previous information about the status
#' bits above the new length.
#'
#' @name length.bit
#' @param x a \code{\link{bit}}, \code{\link{bitwhich}} or \code{\link{ri}}
#' object
#' @param value the new number of bits
#' @return the length A bit vector with the new length
#' @author Jens Oehlschlägel
#' @seealso \code{\link{length}}, \code{\link[=sum.bit]{sum}},
#' \code{\link{poslength}}, \code{\link{maxindex}}
#' @keywords classes logic
#' @examples
#'
#' stopifnot(length(ri(1, 1, 32))==32)
#'
#' x <- as.bit(ri(32, 32, 32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==1)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==0)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==0)
#'
#' x <- as.bit(ri(1, 1, 32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==1)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==1)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==1)
#'
#' x <- as.bitwhich(bit(32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==0)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==0)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==0)
#'
#' x <- as.bitwhich(!bit(32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==32)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==16)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==32)
#'
#' x <- as.bitwhich(ri(32, 32, 32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==1)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==0)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==0)
#'
#' x <- as.bitwhich(ri(2, 32, 32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==31)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==15)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==31)
#'
#' x <- as.bitwhich(ri(1, 1, 32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==1)
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==1)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==1)
#'
#' x <- as.bitwhich(ri(1, 31, 32))
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==31)
#' message("NOTE the change from 'some excluded' to 'all excluded' here")
#' length(x) <- 16
#' stopifnot(length(x)==16)
#' stopifnot(sum(x)==16)
#' length(x) <- 32
#' stopifnot(length(x)==32)
#' stopifnot(sum(x)==32)
#'
#' @export
length.bit <- function(x)
virtual(x)$Length
#' @rdname length.bit
#' @export
"length<-.bit" <- function(x, value){
value <- as.integer(value)
vattr <- attr(x, "virtual")
oldvalue <- attr(vattr, "Length")
if (value!=oldvalue){
pattr <- attr(x, "physical")
cl <- oldClass(x)
oldn <- get_length(x)
dn <- value %% .BITS
if (dn){
n <- value %/% .BITS + 1L
}else{
n <- value %/% .BITS
}
if (oldn<n){
ret <- integer(n)
ret[seq_len(oldn)] <- x
}else if (n<oldn){
ret <- unclass(x)[seq_len(n)]
}else{
ret <- copy_vector(x)
}
if (dn && value<oldvalue){
.Call(C_R_bit_set_logical, ret, FALSE, c(value+1L, n*.BITS))
}
attr(vattr, "Length") <- value
setattributes(ret, list("physical" = pattr, "virtual" = vattr, "class" = cl))
ret
}else
x
}
#' @rdname length.bit
#' @export
length.bitwhich <- function(x)
attr(x, "maxindex")
#' @rdname length.bit
#' @export
"length<-.bitwhich" <- function(x, value){
if (value!=length(x)){
value <- as.integer(value)
a <- attributes(x)
if (value){
if (is.integer(x)){
oldClass(x) <- NULL
if (x[1]>0){
ret <- x[x <= value]
l <- length(ret)
if (l==0)
ret <- copy_vector(FALSE)
else if (l==value)
ret <- copy_vector(TRUE)
else if (l>(value%/%2L))
ret <- merge_rangediff(c(-value,-1L), ret, revy=TRUE)
}else{
ret <- x[x >= -value]
l <- length(ret)
if (l==0)
ret <- copy_vector(TRUE)
else if (l==value)
ret <- copy_vector(FALSE)
else if (!((value-l)>(value%/%2L)))
ret <- merge_rangediff(c(1L,value), ret, revy=TRUE)
l <- value - l
}
}else{
if (length(x) && x){
ret <- bitwhich(value, x=TRUE, poslength=value)
l <- value
}else{
ret <- bitwhich(value, x=FALSE, poslength=0L)
l <- 0L
}
}
}else{
ret <- bitwhich()
l <- 0L
}
}
a$maxindex <- value
a$poslength <- l
setattributes(ret, a)
ret
}
#' Concatenating booltype vectors
#'
#' Creating new boolean vectors by concatenating boolean vectors
#'
#' @param \dots \code{\link{booltype}} vectors
#' @return a vector with the lowest input \code{\link{booltype}} (but not lower than\code{\link{logical}})
#' @author Jens Oehlschlägel
#' @seealso \code{\link{c}}, \code{\link{bit}} , \code{\link{bitwhich}}, , \code{\link{which}}
#' @keywords classes logic
#' @examples
#' c(bit(4), !bit(4))
#' c(bit(4), !bitwhich(4))
#' c(bitwhich(4), !bit(4))
#' c(ri(1,2,4), !bit(4))
#' c(bit(4), !logical(4))
#' message("logical in first argument does not dispatch: c(logical(4), bit(4))")
#' c.booltype(logical(4), !bit(4))
#'
#' @export c.booltype
#' @export
c.booltype <- function(...){
l <- list(...)
bt <- sapply(l, booltype)
# xx TEMPORARY WORKAROND: work around a bug in sapply which destroys ordered levels
class(bt) <- c("ordered", "factor")
bt <- max(booltypes[["logical"]], min(bt, booltypes[["bitwhich"]]))
bt <- as.character(bt)
f <- list(logical=as.logical, bit=as.bit, bitwhich=as.bitwhich, which=as.which)[[bt]]
l <- lapply(l, f)
do.call(switch(bt
, logical="c"
, bit="c.bit"
, bitwhich="c.bitwhich"
), l)
}
#' @rdname c.booltype
#' @export
c.bit <- function(...){
l <- list(...)
nl <- length(l)
nold <- sapply(l, length)
nnew <- sum(nold)
ncum <- cumsum(nold)
offsets <- c(0L, ncum[-length(ncum)])
x <- bit(nnew)
for (i in seq_len(nl)){
b <- as.bit(l[[i]])
.Call(C_R_bit_shiftcopy, bsource_=b, btarget_=x, otarget_=offsets[i], n_=nold[i])
}
x
}
#' @rdname c.booltype
#' @export
c.bitwhich <- function(...){
l <- list(...)
if (length(l)==1)
l[[1]]
else
as.bitwhich(do.call("c", lapply(l, as.bit)))
}
#' Reversing bit and bitwhich vectors
#'
#' Creating new bit or bitwhich by reversing such vectors
#'
#' @name rev.booltype
#' @param x bit or bitwhich object
#' @return An object of class 'bit' or 'bitwhich'
#' @author Jens Oehlschlägel
#' @seealso \code{\link{rev}}, \code{\link{bit}} , \code{\link{bitwhich}}
#' @keywords classes logic
#' @examples
#'
#' rev(as.bit(c(FALSE,TRUE)))
#' rev(as.bitwhich(c(FALSE,TRUE)))
NULL
#' @rdname rev.booltype
#' @export
rev.bit <- function(x){
if (length(x)){
x <- .Call(C_R_bit_reverse, x, bit(length(x)))
}
x
}
#' @rdname rev.booltype
#' @export
rev.bitwhich <- function(x){
n <- length(x)
if (is.logical(x)){
ret <- bitwhich(n, copy_vector(x), poslength=sum(x))
}else{
y <- bitwhich_representation(x)
if (n < .Machine$integer.max){
if (y[1]<0)
ret <- bitwhich(n, -(n+1L)-reverse_vector(x), poslength=sum(x))
else
ret <- bitwhich(n, (n+1L)-reverse_vector(x), poslength=sum(x))
}else{
if (y[1]<0)
ret <- bitwhich(n, -n-reverse_vector(x)-1L, poslength=sum(x))
else
ret <- bitwhich(n, n-reverse_vector(x)+1L, poslength=sum(x))
}
}
ret
}
#' Replicating bit and bitwhich vectors
#'
#' Creating new bit or bitwhich by recycling such vectors
#'
#' @name rep.booltype
#' @param x bit or bitwhich object
#' @param times number of replications
#' @param length.out final length of replicated vector (dominates times)
#' @param \dots not used
#' @return An object of class 'bit' or 'bitwhich'
#' @author Jens Oehlschlägel
#' @seealso \code{\link{rep}}, \code{\link{bit}} , \code{\link{bitwhich}}
#' @keywords classes logic
#' @examples
#'
#' rep(as.bit(c(FALSE,TRUE)), 2)
#' rep(as.bit(c(FALSE,TRUE)), length.out=7)
#' rep(as.bitwhich(c(FALSE,TRUE)), 2)
#' rep(as.bitwhich(c(FALSE,TRUE)), length.out=1)
NULL
#' @rdname rep.booltype
#' @export
rep.bit <- function(x, times = 1L, length.out = NA, ...){
if (length(times)>1L)
stop("only scalar times supported")
if (is.na(length.out))
length.out <- length(x)*as.integer(times)
else
length.out <- as.integer(length.out)
ret <- bit(length.out)
.Call(C_R_bit_recycle, ret, x)
}
#' @rdname rep.booltype
#' @export
rep.bitwhich <- function(x, times = 1L, length.out = NA, ...){
as.bitwhich(rep(as.bit(x), times=times, length.out=as.integer(length.out), ...))
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} (zero length) from \code{\link{NULL}}
#' @export
as.bit.NULL <- function(x, ...){
bit(0L)
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{bit}}
#' @export
as.bit.bit <- function(x, ...)
x
#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{logical}}
#' @export
as.bit.logical <- function(x, ...){
n <- length(x)
b <- bit(n)
.Call(C_R_bit_set_logical, b, x, c(1L, n))
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} from
#' \code{\link{integer}} (\code{0L} and \code{NA} become \code{FALSE},
#' everthing else becomes \code{TRUE})
#' @examples as.bit(c(0L,1L,2L,-2L,NA))
#' @export
as.bit.integer <- function(x, ...){
n <- length(x)
b <- bit(n)
.Call(C_R_bit_set_integer, b, x, c(1L, n))
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} from
#' \code{\link{double}} (\code{0} and \code{NA} become \code{FALSE}, everthing
#' else becomes \code{TRUE})
#' @examples as.bit(c(0,1,2,-2,NA))
#' @export
as.bit.double <- function(x, ...){
n <- length(x)
b <- bit(n)
.Call(C_R_bit_set_integer, b, as.integer(x), c(1L, n))
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{bitwhich}}
#' @export
as.bit.bitwhich <- function(x, ...){
if (length(x)){
b <- bit(length(x))
if (is.logical(x)){
if (unclass(x))
!b
else
b
}else{
.Call(C_R_bit_replace, b, x, TRUE)
}
}else{
bit()
}
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link[=as.which]{which}}
#' @export
as.bit.which <- function(x, length=attr(x, "maxindex"), ...){
if (is.na(length))
stop("cannot coerce to bit from which object with unknown maxindex")
b <- bit(length)
.Call(C_R_bit_replace, b, x, TRUE)
}
#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{ri}}
#' @export
as.bit.ri <- function(x, ...){
if (is.na(x[3]))
stop("cannot coerce to bit from ri object with unknown maxindex")
b <- bit(x[3])
.Call(C_R_bit_set_logical, b, TRUE, x)
}
#' Coercion from bit, bitwhich, which and ri to logical, integer, double
#'
#' Coercion from bit is quite fast because we use a double loop that fixes each
#' word in a processor register.
#'
#' @name CoercionToStandard
#' @param x an object of class \code{\link{bit}}, \code{\link{bitwhich}} or
#' \code{\link{ri}}
#' @param length length of the boolean vector (required for \code{as.logical.which})
#' @param \dots ignored
#' @return \code{\link{as.logical}} returns a vector of \code{FALSE, TRUE},
#' \code{\link{as.integer}} and \code{\link{as.double}} return a vector of
#' \code{0,1}.
#' @author Jens Oehlschlägel
#' @seealso \code{\link{CoercionToStandard}}, \code{\link{as.booltype}}, \code{\link{as.bit}}, \code{\link{as.bitwhich}}
#' , \code{\link{as.which}}, \code{\link{as.ri}}, \code{\link[ff]{as.hi}}, \code{\link[ff]{as.ff}}
#' @keywords classes logic
#' @examples
#'
#' x <- ri(2, 5, 10)
#' y <- as.logical(x)
#' y
#' stopifnot(identical(y, as.logical(as.bit(x))))
#' stopifnot(identical(y, as.logical(as.bitwhich(x))))
#'
#' y <- as.integer(x)
#' y
#' stopifnot(identical(y, as.integer(as.logical(x))))
#' stopifnot(identical(y, as.integer(as.bit(x))))
#' stopifnot(identical(y, as.integer(as.bitwhich(x))))
#'
#' y <- as.double(x)
#' y
#' stopifnot(identical(y, as.double(as.logical(x))))
#' stopifnot(identical(y, as.double(as.bit(x))))
#' stopifnot(identical(y, as.double(as.bitwhich(x))))
NULL
#' @rdname CoercionToStandard
#' @export
as.logical.bit <- function(x, ...){
l <- logical(length(x))
.Call(C_R_bit_get_logical, x, l, c(1L, length(x)))
}
#' @rdname CoercionToStandard
#' @export
as.integer.bit <- function(x, ...){
l <- integer(length(x))
.Call(C_R_bit_get_integer, x, l, c(1L, length(x)))
}
#' @rdname CoercionToStandard
#' @export
as.double.bit <- function(x, ...){
l <- integer(length(x))
as.double(.Call(C_R_bit_get_integer, x, l, c(1L, length(x))))
}
#' @rdname CoercionToStandard
#' @export
as.integer.bitwhich <- function(x, ...){
n <- length(x)
if (is.logical(x)){
if (sum(x)==n)
rep(1L, n)
else
rep(0L, n)
}else{
ret <- integer(n)
ret[x] <- 1L
ret
}
}
#' @rdname CoercionToStandard
#' @export
as.double.bitwhich <- function(x, ...){
n <- length(x)
if (is.logical(x)){
if (sum(x)==n)
rep(1, n)
else
rep(0, n)
}else{
ret <- double(n)
ret[x] <- 1
ret
}
}
#' @rdname CoercionToStandard
#' @export
as.logical.bitwhich <- function(x, ...){
n <- length(x)
p <- sum(x)
if (p==0){
rep(FALSE, length(x))
}else if (p==n){
rep(TRUE, length(x))
}else{
ret <- logical(length(x))
ret[x] <- TRUE
ret
}
}
#' @rdname CoercionToStandard
#' @export
as.logical.ri <- function(x, ...){
if (is.na(x[3]))
stop("cannot coerce to logical from ri object with unknown maxindex")
ret <- logical(x[3])
ret[x[1]:x[2]] <- TRUE
ret
}
#' @rdname CoercionToStandard
#' @export
as.integer.ri <- function(x, ...){
if (is.na(x[3]))
stop("cannot coerce to integer from ri object with unknown maxindex")
ret <- integer(x[3])
ret[x[1]:x[2]] <- 1L
ret
}
#' @rdname CoercionToStandard
#' @export
as.double.ri <- function(x, ...){
if (is.na(x[3]))
stop("cannot coerce to integer from ri object with unknown maxindex")
ret <- double(x[3])
ret[x[1]:x[2]] <- 1
ret
}
#' @rdname CoercionToStandard
#' @export
as.logical.which <- function(x, length=attr(x, "maxindex"), ...){
if (is.na(length))
stop("cannot coerce to logical from which object with unknown maxindex")
l <- logical(length)
l[x] <- TRUE
l
}
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link[=as.which]{which}}
#' @export
as.which.which <- function(x, maxindex=NA_integer_, ...)x
#' @describeIn as.which method to coerce to zero length \code{\link[=as.which]{which}} from \code{\link{NULL}}
#' @export
as.which.NULL <- function(x, ...)structure(integer(), maxindex=0L, class=c("booltype", "which"))
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{numeric}}
#' @export
as.which.numeric <- function(x, maxindex=NA_integer_, ...){
as.which(as.integer(x), maxindex=maxindex, ...)
}
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{integer}}
#' @export
as.which.integer <- function(x, maxindex=NA_integer_, is.unsorted=TRUE, has.dup=TRUE, ...){
ret <- range_nanozero(as.integer(x))
r <- getsetattr(ret, "range_na", NULL)
if (length(ret)){
if (r[3]>0L)
stop("NA positions not allowed (neither positive nor negative)")
if (r[1]<0L){
if (r[2]>0L)
stop("mixed negative and positive subscripts not allowed")
if (is.na(maxindex))
stop("need maxindex with negative subscripts")
else if (-r[1] > maxindex)
stop("index value outside -maxindex..-1")
}else{
if (!is.na(maxindex) && r[2] > maxindex)
stop("index value outside 1..maxindex")
}
if (is.unsorted)
ret <- bit_sort_unique(ret, na.last=NA, range_na=r, has.dup=has.dup)
else if (has.dup)
ret <- bit_unique(ret, na.rm = FALSE, range_na=r)
if (r[1]<0L)
ret <- merge_rangediff(c(1L,maxindex), ret, revx=FALSE, revy=TRUE)
}
setattributes(ret, list("maxindex" = maxindex, "class" = c("booltype", "which")))
ret
}
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{logical}}
#' @export
as.which.logical <- function(x, ...){
ret <- which(x)
setattributes(ret, list("maxindex" = as.integer(length(x)), "class" = c("booltype", "which")))
ret
}
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{ri}}
#' @export
as.which.ri <- function(x, ...){
ret <- x[1]:x[2]
setattributes(ret, list("maxindex" = as.integer(x[3]), "class" = c("booltype", "which")))
ret
}
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{bit}}
#' @export
as.which.bit <- function(x, range=NULL, ...){
maxindex <- length(x)
if (is.null(range))
range <- c(1L, maxindex)
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>maxindex)
stop("illegal range")
}
s <- sum(x, range=range)
n <- range[2] - range[1] + 1L
if (s==0L){
ret <- integer()
}else if (s==n){
#ret <- as.integer(seq.int(from=range[1], to=range[2], by=1))
ret <- merge_rangediff(range, integer())
}else
ret <- .Call(C_R_bit_which, x, s, range, negative=FALSE)
setattributes(ret, list("maxindex" = as.integer(maxindex), "class" = c("booltype", "which")))
ret
}
#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{bitwhich}}
#' @export
as.which.bitwhich <- function(x, ...){
maxindex <- length(x)
if (is.logical(x)){
if (maxindex && unclass(x))
ret <- seq_len(maxindex)
else
ret <- integer()
}else{
if (unclass(x)[[1]]<0)
ret <- merge_rangediff(c(1L,maxindex), x, revx=FALSE, revy=TRUE)
else
ret <- copy_vector(x)
}
setattributes(ret, list("maxindex" = as.integer(maxindex), "class" = c("booltype", "which")))
ret
}
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} (zero length) from \code{\link{NULL}}
#' @export
as.bitwhich.NULL <- function(x, ...){
bitwhich()
}
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{bitwhich}}
#' @export
as.bitwhich.bitwhich <- function(x, ...){
x
}
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link[=as.which]{which}}
#' @export
as.bitwhich.which <- function(x, maxindex=attr(x, "maxindex"), ...){
if (is.na(maxindex))
stop("need maxindex")
if (maxindex==0)
bitwhich()
else{
poslength <- length(x)
if (poslength==0)
bitwhich(maxindex, FALSE, poslength)
else if (poslength==maxindex)
bitwhich(maxindex, TRUE, poslength)
else if (poslength>(maxindex%/%2L)){
bitwhich(maxindex, merge_rangediff(c(1L,maxindex), x, revx=TRUE, revy=TRUE), poslength=poslength)
}else{
bitwhich(maxindex, x, poslength=poslength)
}
}
}
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{ri}}
#' @export
as.bitwhich.ri <- function(x, ...){
maxindex <- length(x)
if (is.na(maxindex))
stop("you must provide maxindex with ri() in as.bitwhich.ri()")
# ri selects at least one element,
# hence maxindex>0 and poslength>0
poslength <- sum(x)
if (poslength==maxindex)
bitwhich(maxindex, TRUE, poslength=poslength)
else if (poslength>(maxindex%/%2L)){
if (x[1]>1L) b <- (-x[1]+1L):(-1) else b <- integer()
if (x[2]<maxindex) a <- (-maxindex):(-x[2]-1L) else a <- integer()
bitwhich(maxindex, c(a,b), poslength=poslength)
}else{
bitwhich(maxindex, x[1]:x[2], poslength=poslength)
}
}
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from
#' \code{\link{integer}} (\code{0} and \code{NA} become \code{FALSE}, everthing
#' else becomes \code{TRUE})
#' @examples as.bitwhich(c(0L,1L,2L,-2L,NA))
#' @export
as.bitwhich.integer <- function(x, poslength=NULL, ...)
as.bitwhich(as.logical(x), poslength=poslength, ...)
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from
#' \code{\link{double}} (\code{0} and \code{NA} become \code{FALSE}, everthing
#' else becomes \code{TRUE})
#' @examples as.bitwhich(c(0,1,2,-2,NA))
#' @export
as.bitwhich.double <- as.bitwhich.integer
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{logical}}
#' @export
as.bitwhich.logical <- function(x, poslength=NULL, ...){
maxindex <- length(x)
if (maxindex==0)
bitwhich()
else{
if (is.null(poslength))
poslength <- sum(x, na.rm=TRUE)
else
if(poslength>maxindex)
stop("poslength > maxindex")
if (poslength==0)
bitwhich(maxindex, FALSE, poslength=poslength)
else if (poslength==maxindex)
bitwhich(maxindex, TRUE, poslength=poslength)
else if (poslength>(maxindex%/%2L)){
as.bitwhich(as.bit(x), poslength=poslength)
}else{
bitwhich(maxindex, which(x), poslength=poslength)
}
}
}
#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{bit}}
#' @export
as.bitwhich.bit <- function(x, range=NULL, poslength=NULL, ...){
maxindex <- length(x)
if (maxindex){
if (is.null(range))
range <- c(1L, maxindex)
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>maxindex)
stop("illegal range")
}
if (is.null(poslength))
poslength <- sum(x, range=range, na.rm=TRUE)
else
if(poslength>maxindex)
stop("poslength > maxindex")
if (poslength==0)
bitwhich(maxindex, FALSE, poslength=poslength)
else if (poslength==maxindex)
bitwhich(maxindex, TRUE, poslength=poslength)
else{
if (poslength>(maxindex%/%2L)){
bitwhich(maxindex, .Call(C_R_bit_which, x, maxindex - poslength, range=range, negative=TRUE), poslength=poslength)
}else{
bitwhich(maxindex, .Call(C_R_bit_which, x, poslength, range=range, negative=FALSE), poslength=poslength)
}
}
}else bitwhich()
}
#' Test for NA in bit and bitwhich
#'
#' @name is.na.bit
#' @param x a \code{\link{bit}} or \code{\link{bitwhich}} vector
#'
#' @return vector of same type with all elements \code{FALSE}
#' @seealso \code{\link{is.na}}
#'
#' @examples
#' is.na(bit(6))
#' is.na(bitwhich(6))
is.na.bit <- function(x)bit(length(x))
#' @describeIn is.na.bit method for \code{\link{is.na}} from \code{\link{bitwhich}}
#' @export
is.na.bitwhich <- function(x)bitwhich(length(x))
#' @describeIn xor default method for \code{\link{xor}}
#' @export
xor.default <- function (x, y)
{
cat("default\n")
(x | y) & !(x & y)
}
#' @describeIn xor \code{\link{logical}} method for \code{\link{xor}}
#' @export
xor.logical <- function(x,y){
as.logical(x) != as.logical(y)
}
#' @describeIn xor \code{\link{bit}} method for \code{\link{!}}
#' @export
"!.bit" <- function(x){
if (length(x)){
ret <- copy_vector(x)
setattributes(ret, attributes(x))
.Call(C_R_bit_not, ret)
}else{
x
}
}
#' @describeIn xor \code{\link{bit}} method for \code{\link{&}}
#' @export
"&.bit" <- function(e1, e2){
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bit())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
e1 <- as.bit(e1)
e2 <- as.bit(e2)
ret <- bit(n[1])
.Call(C_R_bit_and, e1, e2, ret)
}
#' @describeIn xor \code{\link{bit}} method for \code{\link{|}}
#' @export
"|.bit" <- function(e1, e2){
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bit())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
e1 <- as.bit(e1)
e2 <- as.bit(e2)
ret <- bit(n[1])
.Call(C_R_bit_or, e1, e2, ret)
}
#' @describeIn xor \code{\link{bit}} method for \code{\link{==}}
#' @export
"==.bit" <- function(e1, e2){
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bit())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
e1 <- as.bit(e1)
e2 <- as.bit(e2)
ret <- bit(n[1])
.Call(C_R_bit_equal, e1, e2, ret)
}
#' @describeIn xor \code{\link{bit}} method for \code{\link{!=}}
#' @export
"!=.bit" <- function(e1, e2){
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bit())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
e1 <- as.bit(e1)
e2 <- as.bit(e2)
ret <- bit(n[1])
.Call(C_R_bit_xor, e1, e2, ret)
}
#' @describeIn xor \code{\link{bit}} method for \code{\link{xor}}
#' @export
"xor.bit" <- function(x, y){
n <- c(length(x), length(y))
if (any(n==0L))
return(bit())
if(n[1]!=n[2])
stop("length(x) != length()")
x <- as.bit(x)
y <- as.bit(y)
ret <- bit(n[1])
.Call(C_R_bit_xor, x, y, ret)
}
#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{!}}
#' @export
"!.bitwhich" <- function(x){
n <- length(x)
p <- sum(x)
if (is.logical(x)){
if (n==0)
bitwhich()
else if (p==n){
bitwhich(maxindex=n, FALSE, poslength=0L)
}else{
bitwhich(maxindex=n, TRUE, poslength=n)
}
}else{
#bitwhich(maxindex=n, -rev(unclass(x)), poslength=n-p, is.unsorted = FALSE, has.dup=FALSE)
bitwhich(maxindex=n, copy_vector(x, revx=TRUE), poslength=n-p, is.unsorted = FALSE, has.dup=FALSE)
}
}
#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{&}}
#' @export
"&.bitwhich" <- function(e1, e2){
e1 <- as.bitwhich(e1)
e2 <- as.bitwhich(e2)
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bitwhich())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
p <- c(sum(e1), sum(e2))
if (p[1]==0 || p[2]==0)
return(bitwhich(n[1], FALSE, 0L))
if (p[1]==n[1])
return(e2)
if (p[2]==n[2])
return(e1)
#negative <- p>(n%/%2L)
negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
if (negative[1]){
if (negative[2]){
ret <- merge_union(e1, e2, method="exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}else{
ret <- merge_setdiff(e2, e1, revy=TRUE, method="exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}
}else{
if (negative[2]){
ret <- merge_setdiff(e1, e2, revy=TRUE, method="exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}else{
ret <- merge_intersect(e1, e2, method="exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}
}
}
#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{|}}
#' @export
"|.bitwhich" <- function(e1, e2){
e1 <- as.bitwhich(e1)
e2 <- as.bitwhich(e2)
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bitwhich())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
p <- c(sum(e1), sum(e2))
if (p[1]==n[1] || p[2]==n[2])
return(bitwhich(n[1], TRUE, n[1]))
if (p[1]==0)
return(e2)
if (p[2]==0)
return(e1)
#negative <- p>(n%/%2L)
negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
if (negative[1]){
if (negative[2]){
ret <- merge_intersect(e1, e2, method="exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}else{
ret <- merge_setdiff(e1, e2, revy=TRUE, method="exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}
}else{
if (negative[2]){
ret <- merge_setdiff(e2, e1, revy=TRUE, method="exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}else{
ret <- merge_union(e1, e2, method="exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}
}
}
#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{==}}
#' @export
"==.bitwhich" <- function(e1, e2){
e1 <- as.bitwhich(e1)
e2 <- as.bitwhich(e2)
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bitwhich())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
p <- c(sum(e1), sum(e2))
if (p[1]==0)
return(!e2)
if (p[1]==n[1])
return(e2)
if (p[2]==0)
return(!e1)
if (p[2]==n[2])
return(e1)
#negative <- p>(n%/%2L)
negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
if (negative[1]){
if (negative[2]){
ret <- merge_symdiff(e1, e2, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}else{
ret <- merge_symdiff(e1, e2, revx=TRUE, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}
}else{
if (negative[2]){
ret <- merge_symdiff(e1, e2, revy=TRUE, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}else{
ret <- merge_symdiff(e1, e2, revx=TRUE, revy=TRUE, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}
}
}
#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{!=}}
#' @export
"!=.bitwhich" <- function(e1, e2){
e1 <- as.bitwhich(e1)
e2 <- as.bitwhich(e2)
n <- c(length(e1), length(e2))
if (any(n==0L))
return(bitwhich())
if(n[1]!=n[2])
stop("length(e1) != length(e2)")
p <- c(sum(e1), sum(e2))
if (p[1]==0)
return(e2)
if (p[1]==n[1])
return(!e2)
if (p[2]==0)
return(e1)
if (p[2]==n[2])
return(!e1)
#negative <- p>(n%/%2L)
negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
if (negative[1]){
if (negative[2]){
ret <- merge_symdiff(e1, e2, revx=TRUE, revy=TRUE, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}else{
ret <- merge_symdiff(e1, e2, revy=TRUE, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}
}else{
if (negative[2]){
ret <- merge_symdiff(e1, e2, revx=TRUE, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
}else{
ret <- merge_symdiff(e1, e2, method = "exact")
bitwhich(maxindex=n[1], ret, poslength=length(ret))
}
}
}
#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{xor}}
#' @export
"xor.bitwhich" <- function(x, y) x != y
#' @describeIn xor \code{\link{booltype}} method for \code{\link{&}}
#' @export &.booltype
#' @export
"&.booltype" <- function(e1, e2){
# align booltype between logical and bitwhich
b1 <- booltype(e1)
b2 <- booltype(e2)
b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
e1 <- as.booltype(e1, b)
e2 <- as.booltype(e2, b)
# align length
n1 <- length(e1)
n2 <- length(e2)
if (n1 && n2){
if (n1 < n2){
if (n2%%n1)
warning("longer object length is not a multiple of shorter object length")
e1 <- rep(e1, length.out=n2)
n1 <- n2
}else if (n2 < n1){
if (n1%%n2)
warning("longer object length is not a multiple of shorter object length")
e2 <- rep(e2, length.out=n1)
}
}
# do the operation
switch( as.character(b)
, "logical" = e1 & e2
, "bit" = "&.bit"(e1, e2)
, "bitwhich" = "&.bitwhich"(e1, e2)
)
}
#' @describeIn xor \code{\link{booltype}} method for \code{\link{|}}
#' @export |.booltype
#' @export
"|.booltype" <- function(e1, e2){
# align booltype between logical and bitwhich
b1 <- booltype(e1)
b2 <- booltype(e2)
b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
e1 <- as.booltype(e1, b)
e2 <- as.booltype(e2, b)
# align length
n1 <- length(e1)
n2 <- length(e2)
if (n1 && n2){
if (n1 < n2){
if (n2%%n1)
warning("longer object length is not a multiple of shorter object length")
e1 <- rep(e1, length.out=n2)
n1 <- n2
}else if (n2 < n1){
if (n1%%n2)
warning("longer object length is not a multiple of shorter object length")
e2 <- rep(e2, length.out=n1)
}
}
# do the operation
switch( as.character(b)
, "logical" = e1 | e2
, "bit" = "|.bit"(e1, e2)
, "bitwhich" = "|.bitwhich"(e1, e2)
)
}
#' @describeIn xor \code{\link{booltype}} method for \code{\link{==}}
#' @export ==.booltype
#' @export
"==.booltype" <- function(e1, e2){
# align booltype between logical and bitwhich
b1 <- booltype(e1)
b2 <- booltype(e2)
b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
e1 <- as.booltype(e1, b)
e2 <- as.booltype(e2, b)
# align length
n1 <- length(e1)
n2 <- length(e2)
if (n1 && n2){
if (n1 < n2){
if (n2%%n1)
warning("longer object length is not a multiple of shorter object length")
e1 <- rep(e1, length.out=n2)
n1 <- n2
}else if (n2 < n1){
if (n1%%n2)
warning("longer object length is not a multiple of shorter object length")
e2 <- rep(e2, length.out=n1)
}
}
# do the operation
switch( as.character(b)
, "logical" = e1 == e2
, "bit" = "==.bit"(e1, e2)
, "bitwhich" = "==.bitwhich"(e1, e2)
)
}
#' @describeIn xor \code{\link{booltype}} method for \code{\link{!=}}
#' @export !=.booltype
#' @export
"!=.booltype" <- function(e1, e2){
# align booltype between logical and bitwhich
b1 <- booltype(e1)
b2 <- booltype(e2)
b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
e1 <- as.booltype(e1, b)
e2 <- as.booltype(e2, b)
# align length
n1 <- length(e1)
n2 <- length(e2)
if (n1 && n2){
if (n1 < n2){
if (n2%%n1)
warning("longer object length is not a multiple of shorter object length")
e1 <- rep(e1, length.out=n2)
n1 <- n2
}else if (n2 < n1){
if (n1%%n2)
warning("longer object length is not a multiple of shorter object length")
e2 <- rep(e2, length.out=n1)
}
}
# do the operation
switch( as.character(b)
, "logical" = e1 != e2
, "bit" = "!=.bit"(e1, e2)
, "bitwhich" = "!=.bitwhich"(e1, e2)
)
}
#' @describeIn xor \code{\link{booltype}} method for \code{\link{xor}}
#' @export xor.booltype
#' @export
"xor.booltype" <- function(x, y){
x != y
}
#' Summaries of boolean vectors
#'
#' Fast aggregation functions for \code{\link{booltype}} vectors. namely \code{\link{bit}}, \code{\link{all}}, \code{\link{any}}, \code{\link{anyNA}},
#' \code{\link{min}}, \code{\link{max}}, \code{\link{range}},
#' \code{\link{sum}} and \code{\link{summary}}.
#' Now all boolean summaries (except for \code{anyNA} because the generic does not allow it) have an optional \code{range} argument to restrict the range of evalution.
#' Note that the boolean summaries have meaning and return values differing from logical aggregation functions: they treat \code{NA} as \code{FALSE},
#' \code{min}, \code{max} and \code{range} give the minimum and maximum positions of \code{TRUE}, \code{summary} returns counts of \code{FALSE}, \code{TRUE} and the \code{range}.
#' Note that you can force the boolean interpretation by calling the booltype method explicitely on any \code{\link{booltypes}} input, e.g. \code{min.booltype()}, see the examples.
#'
#' Summaries of \code{\link{bit}} vectors are quite fast because we use a double loop that fixes each
#' word in a processor register. Furthermore we break out of looping as soon
#' as possible. Summaries of \code{\link{bitwhich}} vectors are even faster, if the selection is very skewed.
#'
#' @name Summaries
#' @param x an object of class bit or bitwhich
#' @param object an object of class bit
#' @param range a \code{\link{ri}} or an integer vector of length==2 giving a
#' range restriction for chunked processing
#' @param recursive formally required but not used
#' @param \dots formally required but not used
#' @return as expected
#' @author Jens Oehlschlägel
#' @seealso \code{\link{length}}
#' @keywords classes logic
#' @examples
#'
#' l <- c(NA, FALSE, TRUE)
#' b <- as.bit(l)
#'
#' all(l)
#' all(b)
#' all(b, range=c(3,3))
#' all.booltype(l, range=c(3,3))
#'
#' min(l)
#' min(b)
#'
#' sum(l)
#' sum(b)
#'
#' summary(l)
#' summary(b)
#' summary.booltype(l)
NULL
# xx MEMO: R CMD check --no-tests --no-manual --no-vignettes bit
#' @rdname Summaries
#' @export
all.bit <- function(x, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(x))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(x))
stop("illegal range")
}
.Call(C_R_bit_all, x, range)
}
#' @rdname Summaries
#' @export
any.bit <- function(x, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(x))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(x))
stop("illegal range")
}
.Call(C_R_bit_any, x, range)
}
#' @rdname Summaries
#' @export
anyNA.bit <- function(x
#, range=NULL
, recursive = FALSE)FALSE
#' @rdname Summaries
#' @export
sum.bit <- function(x, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(x))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(x))
stop("illegal range")
}
.Call(C_R_bit_sum, x, range)
}
#' @rdname Summaries
#' @export
min.bit <- function(x, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(x))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(x))
stop("illegal range")
}
.Call(C_R_bit_min, x, range)
}
#' @rdname Summaries
#' @export
max.bit <- function(x, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(x))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(x))
stop("illegal range")
}
.Call(C_R_bit_max, x, range)
}
#' @rdname Summaries
#' @export
range.bit <- function(x, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(x))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(x))
stop("illegal range")
}
ret <- integer(2)
ret[1] <- .Call(C_R_bit_min, x, range)
if (is.na(ret[1]))
ret[2] <- NA_integer_
else
ret[2] <- .Call(C_R_bit_max, x, range)
ret
}
#' @rdname Summaries
#' @export
summary.bit <- function(object, range=NULL, ...){
if (is.null(range))
range <- c(1L, length(object))
else{
range <- as.integer(range[1:2])
if (range[1]<1L || range[2]>length(object))
stop("illegal range")
}
s <- sum(object, range=range)
r <- range(object, range=range)
c("FALSE"=range[2]-range[1]+1L-s, "TRUE"=s, "Min."=r[1], "Max."=r[2])
}
#' @rdname Summaries
#' @export
all.bitwhich <- function(x, range=NULL, ...){
if (is.null(range))
attr(x, "poslength") == attr(x, "maxindex")
else{
y <- bitwhich_representation(x)
range <- as.integer(range)
if (is.logical(y)){
if (y)
TRUE
else
FALSE
}else{
if (y<0){
all(merge_rangenotin(rx=range, y=x, revx=FALSE, revy=TRUE))
}else{
all(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
}
}
}
}
#' @rdname Summaries
#' @export
any.bitwhich <- function(x, range=NULL, ...){
if (is.null(range))
attr(x, "poslength") > 0L
else{
y <- bitwhich_representation(x)
range <- as.integer(range)
if (is.logical(y)){
if (y)
TRUE
else
FALSE
}else{
if (y<0){
any(merge_rangenotin(rx=range, y=x, revx=FALSE, revy=TRUE))
}else{
any(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
}
}
}
}
#' @rdname Summaries
#' @export
anyNA.bitwhich <- function(x
#, range=NULL
, recursive = FALSE)FALSE
#' @rdname Summaries
#' @export
sum.bitwhich <- function(x, range=NULL, ...){
if (is.null(range))
attr(x, "poslength")
else{
y <- bitwhich_representation(x)
range <- as.integer(range)
if (is.logical(y)){
if (y)
range[2] - range[1] + 1L
else
0L
}else{
if (y<0){
sum(merge_rangenotin(rx=range, y=x, revx=FALSE, revy=TRUE))
}else{
sum(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
}
}
}
}
#' @rdname Summaries
#' @export
min.bitwhich <- function(x, range=NULL, ...){
y <- bitwhich_representation(x)
if (is.logical(y)){
if (length(y) && y)
1L
else
NA_integer_
}else{
if (is.null(range)){
if (y<0L){
merge_firstnotin(c(1L,length(x)), x, revy=TRUE)
}else{
merge_first(x)
}
}else{
range <- as.integer(range)
if (y<0L){
merge_firstnotin(range, x, revy=TRUE)
}else{
merge_firstin(range, x)
}
}
}
}
#' @rdname Summaries
#' @export
max.bitwhich <- function(x, range=NULL, ...){
y <- bitwhich_representation(x)
if (is.logical(y)){
if (length(y) && y)
length(x)
else
NA_integer_
}else{
if (is.null(range)){
if (y<0L){
merge_lastnotin(c(1L,length(x)), x, revy=TRUE)
}else{
merge_last(x)
}
}else{
range <- as.integer(range)
if (y<0L){
merge_lastnotin(range, x, revy=TRUE)
}else{
merge_lastin(range, x)
}
}
}
}
#' @rdname Summaries
#' @export
range.bitwhich <- function(x, range=NULL, ...){
c(min(x, range=range, ...), max(x, range=range, ...))
}
#' @rdname Summaries
#' @export
summary.bitwhich <- function(object, range=NULL, ...){
n <- attr(object, "maxindex")
p <- attr(object, "poslength")
r <- range(object)
c("FALSE"=n-p, "TRUE"=p, "Min."=r[1], "Max."=r[2])
}
#' @rdname Summaries
#' @export
all.which <- function(x, range=NULL, ...){
if (is.null(range))
length(x) == attr(x, "maxindex")
else{
range <- as.integer(range)
all(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
}
}
#' @rdname Summaries
#' @export
any.which <- function(x, range=NULL, ...){
if (is.null(range))
length(x) > 0L
else{
range <- as.integer(range)
any(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
}
}
#' @rdname Summaries
#' @export
anyNA.which <- function(x
#, range=NULL
, recursive = FALSE)FALSE
#' @rdname Summaries
#' @export
sum.which <- function(x, range=NULL, ...){
if (is.null(range))
length(x)
else{
sum(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
}
}
#' @rdname Summaries
#' @export
min.which <- function(x, range=NULL, ...){
if (is.null(range)){
merge_first(x)
}else{
range <- as.integer(range)
merge_firstin(range, x)
}
}
#' @rdname Summaries
#' @export
max.which <- function(x, range=NULL, ...){
if (is.null(range)){
merge_last(x)
}else{
range <- as.integer(range)
merge_lastin(range, x)
}
}
#' @rdname Summaries
#' @export
range.which <- function(x, range=NULL, ...){
c(min(x, range=range, ...), max(x, range=range, ...))
}
#' @rdname Summaries
#' @export
summary.which <- function(object, range=NULL, ...){
n <- attr(object, "maxindex")
p <- attr(object, "poslength")
r <- range(object)
c("FALSE"=n-p, "TRUE"=p, "Min."=r[1], "Max."=r[2])
}
#' @rdname Summaries
#' @export all.booltype
#' @export
all.booltype <- function(x, range=NULL, ...){
switch(as.character(booltype(x))
, nobool=all.bit(as.bit(x), range=range, ...)
, logical=all.bit(as.bit(x), range=range, ...)
, bit=all.bit(x, range=range, ...)
, bitwhich=all.bitwhich(x, range=range, ...)
, which=all.bit(as.bit(x), range=range, ...)
, hi=stop("not implemented")
, ri=all.ri(x, range=range, ...)
)
}
#' @rdname Summaries
#' @export any.booltype
#' @export
any.booltype <- function(x, range=NULL, ...){
switch(as.character(booltype(x))
, nobool=any.bit(as.bit(x), range=range, ...)
, logical=any.bit(as.bit(x), range=range, ...)
, bit=any.bit(x, range=range, ...)
, bitwhich=any.bitwhich(x, range=range, ...)
, which=any.bit(as.bit(x), range=range, ...)
, hi=stop("not implemented")
, ri=any.ri(x, range=range, ...)
)
}
#' @rdname Summaries
#' @export anyNA.booltype
#' @export
anyNA.booltype <- function(x
#, range=NULL
, ...){
switch(as.character(booltype(x))
, nobool=anyNA.bit(as.bit(x)
#, range=range
, ...)
, logical=anyNA.bit(as.bit(x)
#, range=range
, ...)
, bit=anyNA.bit(x
#, range=range
, ...)
, bitwhich=anyNA.bitwhich(x
#, range=range
, ...)
, which=anyNA.bit(as.bit(x)
#, range=range
, ...)
, hi=stop("not implemented")
, ri=anyNA.ri(x
#, range=range
, ...)
)
}
#' @rdname Summaries
#' @export sum.booltype
#' @export
sum.booltype <- function(x, range=NULL, ...){
switch(as.character(booltype(x))
, nobool=sum.bit(as.bit(x), range=range, ...)
, logical=sum.bit(as.bit(x), range=range, ...)
, bit=sum.bit(x, range=range, ...)
, bitwhich=sum.bitwhich(x, range=range, ...)
, which=sum.bit(as.bit(x), range=range, ...)
, hi=stop("not implemented")
, ri=sum.ri(x, range=range, ...)
)
}
#' @rdname Summaries
#' @export min.booltype
#' @export
min.booltype <- function(x, range=NULL, ...){
switch(as.character(booltype(x))
, nobool=min.bit(as.bit(x), range=range, ...)
, logical=min.bit(as.bit(x), range=range, ...)
, bit=min.bit(x, range=range, ...)
, bitwhich=min.bitwhich(x, range=range, ...)
, which=min.bit(as.bit(x), range=range, ...)
, hi=stop("not implemented")
, ri=min.ri(x, range=range, ...)
)
}
#' @rdname Summaries
#' @export max.booltype
#' @export
max.booltype <- function(x, range=NULL, ...){
switch(as.character(booltype(x))
, nobool=max.bit(as.bit(x), range=range, ...)
, logical=max.bit(as.bit(x), range=range, ...)
, bit=max.bit(x, range=range, ...)
, bitwhich=max.bitwhich(x, range=range, ...)
, which=max.bit(as.bit(x), range=range, ...)
, hi=stop("not implemented")
, ri=max.ri(x, range=range, ...)
)
}
#' @rdname Summaries
#' @export range.booltype
#' @export
range.booltype <- function(x, range=NULL, ...){
switch(as.character(booltype(x))
, nobool=range.bit(as.bit(x), range=range, ...)
, logical=range.bit(as.bit(x), range=range, ...)
, bit=range.bit(x, range=range, ...)
, bitwhich=range.bitwhich(x, range=range, ...)
, which=range.bit(as.bit(x), range=range, ...)
, hi=stop("not implemented")
, ri=range.ri(x, range=range, ...)
)
}
#' @rdname Summaries
#' @export summary.booltype
#' @export
summary.booltype <- function(object, range=NULL, ...){
switch(as.character(booltype(object))
, nobool=summary.bit(as.bit(object), range=range, ...)
, logical=summary.bit(as.bit(object), range=range, ...)
, bit=summary.bit(object, range=range, ...)
, bitwhich=summary.bitwhich(object, range=range, ...)
, which=summary.bit(as.bit(object), range=range, ...)
, hi=stop("not implemented")
, ri=summary.ri(object, range=range, ...)
)
}
#' Extract or replace part of an boolean vector
#'
#' Operators acting on \code{\link{bit}} or \code{\link{bitwhich}} objects to extract or replace parts.
#'
#' The typical usecase for for '[' and '[<-' is subscripting with positive integers,
#' negative integers are allowed but slower,
#' as logical subscripts only scalars are allowed.
#' The subscript can be given as a \code{\link{bitwhich}} object.
#' Also \code{\link{ri}} can be used as subscript.
#'
#' Extracting from \code{\link{bit}} and \code{\link{bitwhich}} is faster than from \code{\link{logical}} if positive subscripts are used.
#' integer subscripts make sense. Negative subscripts are converted to
#' positive ones, beware the RAM consumption.
#'
#' @name Extract
#' @param x a \code{\link{bit}} or \code{\link{bitwhich}} object
#' @param i preferrably a positive integer subscript or a \code{\link{ri}}, see text
#' @param value new logical or integer values
#' @return The extractors \code{[[} and \code{[} return a logical scalar or
#' vector. The replacment functions return an object of \code{class(x)}.
#' @author Jens Oehlschlägel
#' @seealso \code{\link{bit}}, \code{\link[base]{Extract}}
#' @keywords classes logic
#' @examples
#'
#' x <- as.bit(c(FALSE, NA, TRUE))
#' x[] <- c(FALSE, NA, TRUE)
#' x[1:2]
#' x[-3]
#' x[ri(1,2)]
#' x[as.bitwhich(c(TRUE,TRUE,FALSE))]
#' x[[1]]
#' x[] <- TRUE
#' x[1:2] <- FALSE
#' x[[1]] <- TRUE
#'
NULL
#' @rdname Extract
#' @export
"[[.bit" <- function(x, i){
if (length(i)!=1L)
stop("subscript length not 1")
if (is.numeric(i)){
i <- as.integer(i)
if (is.na(i) || i<1L || i>length(x))
stop("subscript must be positive integer (or double) within length")
ret <- .Call(C_R_bit_extract, x, i)
setattr(ret, "vmode", "boolean")
ret
}else
stop("subscript must be positive integer (or double) within length")
}
#' @rdname Extract
#' @export
"[[<-.bit" <- function(x, i, value){
if (length(i)!=1L)
stop("subscript length not 1")
if (length(value)!=1)
stop("value length not 1")
if (is.numeric(i)){
i <- as.integer(i)
if (is.na(i) || i<1L)
stop("subscript must be positive integer (or double)")
if ((mi <- max(i))>length(x))
length(x) <- mi
value <- as.logical(value)
.Call(C_R_bit_replace, x, i, value)
}else
stop("subscript must be positive integer (or double) within length")
}
#' @rdname Extract
#' @export
"[.bit" <- function(x, i){
nx <- length(x)
if ( missing(i) ){
ret <- logical(nx)
.Call(C_R_bit_get_logical, x, ret, range=c(1L, nx))
}else{
if (inherits(i, "bit")){
i <- as.bitwhich(i)
}
if (inherits(i, "bitwhich")){
i <- unclass(i)
}
if(is.numeric(i)){
if (inherits(i, "ri")){
if (i[1]<1L || i[2]>nx )
stop("illegal range index 'ri'")
ret <- logical(i[2]-i[1]+1L)
.Call(C_R_bit_get_logical, x, ret, range=i)
}else{
i <- as.integer(i)
r <- range_na(i)
if (is.na(r[1])){
ret <- logical()
}else if (r[1]<0L){
# check for positive or NA mixed with negative
if (r[2]>0L || r[3]>0L)
stop("only 0's may be mixed with negative subscripts")
isasc <- intisasc(i, "none") # NAs checked already, early terminate on FALSE
if (!isasc){
if((length(i) / (r[2]-r[1])) < 0.05)
i <- sort.int(i, method="quick")
else
i <- bit_sort_unique(i)
}
} # is positive, hence no sorting
ret <- .Call(C_R_bit_extract, x, i)
}
}else if(is.logical(i)){
if (poslength(i)==0L){
ret <- logical()
}else{
if (inherits(i, "bitwhich")){
i <- unclass(i)
}else{
if (length(i)!=1 || is.na(i))
stop("only scalar TRUE or FALSE allowed")
}
if (i){
ret <- logical(nx)
.Call(C_R_bit_get_logical, x, ret, range=c(1L, nx))
}else{
ret <- logical()
}
}
}else
stop("subscript must be ri or integer (or double) or TRUE (or missing) or FALSE")
}
setattr(ret, "vmode", "boolean")
ret
}
#' @rdname Extract
#' @export
"[<-.bit" <- function(x, i, value){
nx <- length(x)
value <- as.logical(value)
nv <- length(value)
if (missing(i))
i <- TRUE
if (inherits(i, "bit")){
i <- as.bitwhich(i)
}
if (inherits(i, "bitwhich")){
i <- unclass(i)
}
if (is.logical(i)){
if (length(i)!=1L || is.na(i))
stop("logical only scalar TRUE or FALSE allowed")
if (i){
if (nv==0L)
stop("replacement has length zero")
if (nx %% nv)
warning("number of items to replace is not a multiple of replacement length")
.Call(C_R_bit_set_logical, x, value, range=c(1L, nx))
}else{
x
}
}else if(is.numeric(i)){
if (inherits(i, "ri")){
if (i[1]<1L)
stop("illegal range index 'ri'")
if (i[2]>nx)
length(x) <- i[2]
ni <- i[2] - i[1] + 1L
if (nv==0L)
stop("replacement has length zero")
if (ni %% nv)
warning("number of items to replace is not a multiple of replacement length")
.Call(C_R_bit_set_logical, x, value, range=i)
}else{
if (inherits(i, "which")){
ni <- length(i)
if (ni && i[ni] > nx)
length(x) <- i[ni]
}else{
i <- range_nanozero(as.integer(i))
r <- getsetattr(i, "range_na", NULL)
ni <- length(i)
if (ni){
if (r[3]>0L)
stop("NAs are not allowed in subscripted assignments")
if (r[1]>0L){
if (r[2] > nx)
length(x) <- r[2]
}else{
if (r[2] > 0L)
stop("only 0's may be mixed with negative subscripts")
# R_bit_replace expects sorted i if i is negative
i <- bit_sort_unique(i, range_na = r)
ni <- nx - length(i)
}
}
}
if (nv != ni){
if (nv==0L)
stop("replacement has length zero")
if (ni %% nv)
warning("number of items to replace is not a multiple of replacement length")
}
.Call(C_R_bit_replace, x, i, value)
}
}else stop("subscript must be integer (or double) or ri or bitwhich or TRUE or FALSE or missing")
}
#' Check existence of integers in table
#'
#' If the table is sorted, this can be much faster than \code{\link{\%in\%}}
#'
#' @param x a vector of integer
#' @param table a \code{\link{bitwhich}} object or a vector of integer
#' @param is.unsorted logical telling the function whether the table is (un)sorted. With the defautl \code{NULL} \code{FALSE} is assumed for \code{\link{bitwhich}} tables, otherwise \code{TRUE}
#'
#' @return logical vector
#' @seealso \code{\link{\%in\%}}
#'
#' @examples
#' x <- bitwhich(100)
#' x[3] <- TRUE
#' in.bitwhich(c(NA,2,3), x)
#' @export
in.bitwhich <- function(x, table, is.unsorted=NULL){
x <- as.integer(x)
if (is.null(is.unsorted))
is.unsorted <- !is.bitwhich(table)
if (is.logical(table)){
if (length(table) && table){
1L <= x & x <= length(table)
}else{
rep(FALSE, length(x))
}
}else{
y <- bitwhich_representation(table)
if (length(x)>1L && is.unsorted){
if (y[1]>0L)
!is.na(match(x,table))
else
is.na(match(-x,table))
}else{
if (y[1]>0L)
merge_in(x,table)
else
merge_notin(x,table, revy=TRUE)
}
}
}
#' @rdname Extract
#' @export
"[[.bitwhich" <- function(x, i){
if (length(i)!=1L)
stop("subscript length not 1")
if (is.numeric(i)){
i <- as.integer(i)
if (is.na(i) || i<1L || i>length(x))
stop("subscript must be positive integer (or double) within length")
y <- bitwhich_representation(x)
if (is.logical(y))
ret <- as.vector(x)
else{
ret <- in.bitwhich(i, x)
}
setattr(ret, "vmode", "boolean")
ret
}else
stop("subscript must be positive integer (or double) within length")
}
#' @rdname Extract
#' @export
"[[<-.bitwhich" <- function(x, i, value){
if (length(i)!=1L)
stop("subscript length not 1")
if (length(value)!=1L)
stop("value length not 1")
value <- as.logical(value)
if (is.na(value))
value <- FALSE
n <- length(x)
if (i>n)
warning("increasing length of bitwhich, which has non-standard semantics")
if (is.numeric(i)){
i <- as.integer(i)
if (is.na(i) || i<1L || i>.Machine$integer.max)
stop("subscript must be positive integer (or double)")
y <- bitwhich_representation(x)
if (is.logical(y)){
if (length(y)){
if (value == y){
if (i>n)
length(x) <- i
return(x)
}else if (value)
ret <- bitwhich(max(n,i), i, poslength=1L)
else
ret <- bitwhich(max(n,i), -i, poslength=n-1L)
}else{
if (value)
ret <- bitwhich(i, i, poslength=1L)
else
ret <- bitwhich(i, -i, poslength=n-1L)
}
}else{
if (i>n){
n <- i
length(x) <- i
}
oldvalue <- in.bitwhich(i, x)
if (value == oldvalue)
return(x)
else{
if (value == (y>0)){
ret <- bitwhich(n, merge_union(x, y*i, method = "all"), poslength=attr(x, "poslength")+y)
}else{
ret <- bitwhich(n, merge_setdiff(x, y*i, method = "exact"), poslength=attr(x, "poslength")-y)
}
}
}
}else
stop("subscript must be positive integer (or double) within length")
a <- attributes(x)
a$poslength <- attr(ret, "poslength")
setattributes(ret, a)
ret
}
#' @rdname Extract
#' @export
"[.bitwhich" <- function(x, i){
nx <- length(x)
if ( missing(i) ){
ret <- as.logical(x)
}else{
if (inherits(i, "bit"))
stop("please use as.which(bit) for subscripting with bit")
if (inherits(i, "bitwhich"))
stop("please use unclass(bitwhich) or as.which(bitwhich) to clarify what you want")
if (length(i)==0){
ret <- logical()
}else{
if(is.logical(i)){
if (length(i)!=1L || is.na(i))
stop("only scalar TRUE or FALSE allowed")
if (i){
ret <- as.logical(x)
}else{
ret <- logical()
}
}else if(is.numeric(i)){
if (inherits(i, "ri")){
if (i[1]<1L || i[2]>nx )
stop("illegal range index 'ri'")
if (is.logical(x)){
if (length(x))
ret <- rep(copy_vector(x), i[2]-i[1]+1L)
else
ret <- rep(NA, i[2]-i[1]+1L)
}else{
#y <- unclass(x)
y <- bitwhich_representation(x)
if (y[1]>0L){
#ret <- rep(FALSE, i[2]-i[1]+1L)
#ret[y[i[1]<=y & y<=i[2]] - i[1] + 1L] <- TRUE
ret <- merge_rangein(c(i[1], i[2]), x)
}else{
# ret <- rep(TRUE, i[2]-i[1]+1L)
# ret[-y[(-i[1])>=y & y>=(-i[2])] - i[1] + 1L] <- FALSE
ret <- merge_rangenotin(c(i[1], i[2]), x, revy=TRUE)
}
}
}else{
i <- range_nanozero(as.integer(i))
r <- getsetattr(i, "range_na", NULL)
n <- length(i)
if (r[3]==n) # if allNA
ret <- rep(NA, n)
else{
if (r[1] < 0L && r[2] > 0L)
stop("only 0's may be mixed with negative subscripts")
ret <- as.bit(x)[i]
}
}
}else stop("subscript must be integer (or double) or ri or bitwhich or TRUE or FALSE or missing")
}
}
setattr(ret, "vmode", "boolean")
ret
}
#' @rdname Extract
#' @export
"[<-.bitwhich" <- function(x, i, value){
nx <- length(x)
value <- as.logical(value)
if (anyNA(value))
value[is.na(value)] <- FALSE
nv <- length(value)
if (missing(i))
i <- TRUE
if (inherits(i, "bit"))
stop("please use as.which(bit) for subscripting with bit")
if (inherits(i, "bitwhich"))
stop("please use unclass(bitwhich) or as.which(bitwhich) to clarify what you want")
if (length(i)){
if (is.logical(i)){
if (length(i)!=1L || is.na(i))
stop("logical only scalar TRUE or FALSE allowed")
if (i){
if (nv==1L){
ret <- bitwhich(nx, value)
}else{
b <- as.bit(value)
if (nv==nx){
ret <- as.bitwhich(b)
}else{
if (nv==0L)
stop("replacement has length zero")
if (nx%%nv)
warning("number of items to replace is not a multiple of replacement length")
ret <- as.bitwhich(rep(b, length.out=nx))
}
}
}else{
return(x)
}
}else if(is.numeric(i)){
if (nv>1L){
b <- as.bit(x)
b[i] <- value
ret <- as.bitwhich(b)
}else{
if (inherits(i, "ri")){
if (i[1]<1L)
stop("illegal range index 'ri'")
biggest_mentioned_index <- max(abs(i[1:2]))
i <- i[1]:i[2]
ni <- length(i)
}else{
if (inherits(i, "which")){
ni <- length(i)
biggest_mentioned_index <- i[length(i)]
}else{
i <- range_nanozero(as.integer(i))
r <- getsetattr(i, "range_na", NULL)
if (length(i)){
if (r[3]>0L)
stop("NAs are not allowed in subscripted assignments")
if (r[1]>0L){
# since value is a scalar removing duplicates does not harm and speeds up
i <- bit_sort_unique(i, range_na = r)
ni <- length(i)
}else{
if (r[2] > 0L)
stop("only 0's may be mixed with negative subscripts")
i <- bit_sort_unique(i, range_na = r)
ni <- nx - length(i)
}
# since value is a scalar removing duplicates does not harm and speeds up
biggest_mentioned_index <- max(abs(i[1:2]), na.rm=TRUE)
}else{
ni <- 0L
biggest_mentioned_index <- 0L
}
}
}
if (!ni){
return(x)
}else{
if (nv==0L)
stop("replacement has length zero")
if (biggest_mentioned_index>nx){
length(x) <- biggest_mentioned_index
nx <- biggest_mentioned_index
}
y <- bitwhich_representation(x)
if (is.logical(y)){
if (value == y){
# assignment doesn't change anything
return(x)
}else{
if (value){
# assignment has first inclusions
if (i[1]<0){
# assignment enumerates those not included
ret <- bitwhich(nx, i, poslength=nx-length(i))
}else{
# assignment enumerates those included
ret <- bitwhich(nx, i, poslength=length(i))
}
}else{
# assignment has first exclusions
if (i[1]<0){
# assignment enumerates those not excluded
ret <- bitwhich(nx, copy_vector(i, revx=TRUE), poslength=length(i))
}else{
# assignment enumerates those excluded
ret <- bitwhich(nx, copy_vector(i, revx=TRUE), poslength=nx-length(i))
}
}
}
}else{
if (y<0){
# object maintains exclusions
if (value){
# assignment has inclusions
if (i[1]<0){
# assignment enumerates those not included
# w2 <- w <- bitwhich(12, -(1:3)); w2[-(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_intersect(x,i, method='exact'), xempty=TRUE, is.unsorted = FALSE, has.dup = FALSE) #done
}else{
# assignment enumerates those included
# w2 <- w <- bitwhich(12, -(1:3)); w2[(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_setdiff(x,i,revy=TRUE, method='exact'), xempty=TRUE, is.unsorted = FALSE, has.dup = FALSE) #done
}
}else{
# assignment has exclusions
if (i[1]<0){
# assignment enumerates those not excluded
# w2 <- w <- bitwhich(12, -(1:3)); w2[-(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_setdiff(i, x, revx=TRUE, revy=TRUE, method='exact'), xempty=FALSE, is.unsorted = FALSE, has.dup = FALSE) #done
}else{
# assignment enumerates those excluded
# w2 <- w <- bitwhich(12, -(1:3)); w2[(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_union(x,i,revy=TRUE, method='exact'), is.unsorted = FALSE, has.dup = FALSE) #done
}
}
}else{
# object maintains inclusions
if (value){
# assignment has inclusions
if (i[1]<0){
# assignment enumerates those not included
# w2 <- w <- bitwhich(12, (1:3)); w2[-(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_setdiff(i,x, revy = TRUE, method='exact'), xempty=TRUE, is.unsorted = FALSE, has.dup = FALSE) #done
}else{
# assignment enumerates those included
# w2 <- w <- bitwhich(12, (1:3)); w2[(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_union(x,i, method='exact'), is.unsorted = FALSE, has.dup = FALSE) #done
}
}else{
# assignment has exclusions
if (i[1]<0){
# assignment enumerates those not excluded
# w2 <- w <- bitwhich(12, (1:3)); w2[-(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_intersect(x, i, revy=TRUE, method='exact'), xempty=FALSE, is.unsorted = FALSE, has.dup = FALSE) #done
}else{
# assignment enumerates those excluded
# w2 <- w <- bitwhich(12, (1:3)); w2[(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
ret <- bitwhich(nx, merge_setdiff(x,i, method='exact'), xempty=FALSE, is.unsorted = FALSE, has.dup = FALSE)
}
}
}
}
}
}
}else stop("subscript must be integer (or double) or ri or bitwhich or TRUE or FALSE or missing")
a <- attributes(x)
a$poslength <- sum(ret)
setattributes(ret, a)
ret
}else
x
}
#' Range index
#'
#' A range index can be used to extract or replace a continuous ascending part
#' of the data
#'
#' @param from first position
#' @param to last posistion
#' @param x an object of class 'ri'
#' @param maxindex the maximal length of the object-to-be-subscripted (if
#' known)
#' @param \dots further arguments
#' @return A two element integer vector with class 'ri'
#' @author Jens Oehlschlägel
#' @seealso \code{\link[ff]{as.hi}}
#' @keywords classes logic
#' @examples
#'
#' bit(12)[ri(1,6)]
#'
#' @export ri
ri <- function(from, to=NULL, maxindex=NA){
if (is.null(to)){
x <- as.integer(c(from, maxindex))
}else{
x <- as.integer(c(from, to, maxindex))
}
maxindex = maxindex
if (length(x)!=3 )
stop("range must have exactly three elements")
if (x[[1]]<1L)
stop("range must at least select one element")
if (x[[1]]>x[[2]])
stop("lower bound must be smaller or equal than upper bound")
if (!is.na(x[[3]]) && x[[2]]>x[[3]])
stop("lower and upper bound must be smaller or equal to maxindex")
oldClass(x) <- c("booltype","ri")
x
}
#' @rdname ri
#' @export
print.ri <- function(x, ...)
cat("range index (ri) from", x[[1]], "to", x[[2]], "maxindex", x[[3]], "\n")
#' @rdname length.bit
#' @export
length.ri <- function(x)x[[3]]
#' @rdname Summaries
#' @export
all.ri <- function(x, range=NULL, ...){
if (is.null(range)){
range[[1]] <- 1L
range[[2]] <- x[[3]]
}
x[[1]]<=range[[1]] && x[[2]]>=range[[2]]
}
#' @rdname Summaries
#' @export
any.ri <- function(x, range=NULL, ...){
if (is.null(range)){
range[[1]] <- 1L
range[[2]] <- x[[3]]
}
range[[1]]<=x[[1]] && range[[2]]>=x[[2]]
}
#' @rdname Summaries
#' @export
anyNA.ri <- function(x
#, range=NULL
, recursive = FALSE)FALSE
#' @rdname Summaries
#' @export
sum.ri <- function(x, ...){
if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
x[[2]] - x[[1]] + 1L
}
#' @rdname Summaries
#' @export
min.ri <- function(x, ...){
if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
x[[1]]
}
#' @rdname Summaries
#' @export
max.ri <- function(x, ...){
if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
x[[2]]
}
#' @rdname Summaries
#' @export
range.ri <- function(x, ...){
if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
x[1:2]
}
#' @rdname Summaries
#' @export
summary.ri <- function(object, ...){
if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
s <- object[[2]] - object[[1]] + 1L
c(`FALSE` = object[[3]] - s, `TRUE` = s, Min. = object[[1]], Max. = object[[2]])
}
# this version without vmode() will be overwritte by the version in package ff
#' @rdname PhysVirt
#' @export
physical.default <- function(x){
p <- attributes(attr(x, "physical"))
p <- p[is.na(match(names(p), "class"))]
p
}
#' @rdname PhysVirt
#' @export
"physical<-.default" <- function(x, value){
attributes(attr(x, "physical")) <- c(value, list(class="physical"))
x
}
#' @rdname PhysVirt
#' @export
virtual.default <- function(x){
v <- attributes(attr(x, "virtual"))
v[is.na(match(names(v), "class"))]
}
#' @rdname PhysVirt
#' @export
"virtual<-.default" <- function(x, value){
attributes(attr(x, "virtual")) <- c(value, list(class="virtual"))
x
}
#' @rdname PhysVirt
#' @export
print.physical <- function(x, ...){
cat("(hidden, use physical(x) to access the physical attributes and vmode(x) for accessing vmode)\n")
invisible()
}
#' @rdname PhysVirt
#' @export
print.virtual <- function(x, ...){
cat("(hidden, use virtual(x) to access the virtual attributes)\n")
invisible()
}
# not exported - just here to avoid cross calling the dll from ff
R_bit_as_hi <- function(x, range, offset)
.Call(C_R_bit_as_hi, x, range, offset)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.