1# Functions for boolean vectors
2# (c) 2008-2017 Jens Oehlschägel
3# Licence: GPL2
4# Provided 'as is', use at your own risk
5
6# source("C:/mwp/eanalysis/bit/R/bit.R")
7
8# Configuration: set this to 32L or 64L and keep in sync with BITS in bit.c
9#' @rdname bit_init
10#' @export
11.BITS <- 32L
12
13#' Initializing bit masks
14#'
15#' Functions to allocate (and de-allocate) bit masks
16#'
17#' The C-code operates with bit masks.  The memory for these is allocated
18#' dynamically.  \code{bit_init} is called by \code{\link{.First.lib}} and
19#' \code{bit_done} is called by \code{\link{.Last.lib}}.  You don't need to
20#' care about these under normal circumstances.
21#'
22#' @return NULL
23#' @author Jens Oehlschlägel
24#' @seealso \code{\link{bit}}
25#' @keywords classes logic
26#' @examples
27#'
28#'   bit_done()
29#'   bit_init()
30#'
31#' @export
32bit_init <- function()
33  .Call(C_R_bit_init, .BITS)
34
35#' @rdname bit_init
36#' @export
37bit_done <- function()
38  .Call(C_R_bit_done)
39
40
41
42
43#' Create empty bit vector
44#'
45#' Bit vectors are a boolean type wihout \code{NA} that requires by factor 32 less RAM than \code{\link{logical}}.
46#' 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}
47#'
48#' @param length length in bits
49#' @return \code{bit} returns a vector of integer sufficiently long to store 'length' bits
50#' @seealso  \code{\link{booltype}}, \code{\link{bitwhich}}, \code{\link{logical}}
51#' @keywords classes logic
52#' @examples
53#' bit(12)
54#' !bit(12)
55#' str(bit(128))
56#' @export
57bit <- function(length=0L){
58  length <- as.integer(length)
59  if (length %% .BITS)
60    n <- length %/% .BITS + 1L
61  else
62    n <- length %/% .BITS
63  if (.BITS==64L)
64    x <- integer(2L*n)
65  else
66    x <- integer(n)
67  #physical(x) <- list(vmode="boolean")
68  #virtual(x)  <- list(Length=length)
69  #class(x) <- "bit"
70  # tuning
71  p <- list()
72  v <- list()
73  attributes(p) <- list(vmode="boolean", class="physical")
74  attributes(v) <- list(Length=length, class="virtual")
75  setattributes(x, list(physical=p, virtual=v, class=c("booltype","bit")))
76  x
77}
78
79
80
81#' Print method for bit
82#'
83#' @param x a bit vector
84#' @param ... passed to print
85#' @return a character vector showing first and last elements of the bit vector
86#' @examples
87#' print(bit(120))
88#' @export
89print.bit <- function(x, ...){
90  n <- length(x)
91  cat("bit length=", n, " occupying only ", length(unclass(x)), " int32\n", sep="")
92  if (n>16){
93    y <- c(x[1:8], "..", x[(n-7L):n])
94    names(y) <- c(1:8, "", (n-7L):n)
95    print(y, quote=FALSE, ...)
96  }else if(n){
97    y <- c(x[])
98    names(y) <- c(1:n)
99    print(y, quote=FALSE, ...)
100  }
101}
102
103#' Coerce bit to character
104#'
105#' @param x a \code{\link{bit}} vector
106#' @param ... ignored
107#' @return a character vector of zeroes and ones
108#' @examples
109#' as.character(bit(12))
110#' @export
111as.character.bit <- function(x, ...){
112  c("0","1")[1+as.logical(x)]
113}
114
115
116#' Str method for bit
117#'
118#' To actually view the internal structure use \code{str(unclass(bit))}
119#'
120#' @inheritParams utils::str
121#' @return \code{\link{invisible}}
122#' @importFrom utils strOptions
123#' @examples
124#' str(bit(120))
125#' @export
126str.bit <- function(object
127, vec.len  = strO$vec.len
128, give.head = TRUE
129, give.length = give.head
130, ...
131)
132  {
133  strO <- strOptions()
134  vec.len <- 8*vec.len
135  n <- length(object)
136  if (n>vec.len)
137    object <- as.bit(object[seq_len(vec.len)])
138  cat(if (give.head)paste("bit ", if (give.length && n>1) paste(" [1:",n,"] ",sep=""), sep=""), paste(as.character(object), collapse=" ")," \n", sep="")
139  invisible()
140}
141
142
143#' Coerce bitwhich to character
144#'
145#' @param x a \code{\link{bitwhich}} vector
146#' @param ... ignored
147#' @return a character vector of zeroes and ones
148#' @examples
149#' as.character(bitwhich(12))
150#' @export
151as.character.bitwhich <- function(x, ...)c("0","1")[1+as.logical(x)]
152
153
154#' Str method for bitwhich
155#'
156#' To actually view the internal structure use \code{str(unclass(bitwhich))}
157#'
158#' @inheritParams utils::str
159#' @return \code{\link{invisible}}
160#' @examples
161#' str(bitwhich(120))
162#' @export
163str.bitwhich <- function(object
164                    , vec.len  = strO$vec.len
165                    , give.head = TRUE
166                    , give.length = give.head
167                    , ...
168){
169  strO <- strOptions()
170  vec.len <- 8*vec.len
171  n <- length(object)
172  if (n>vec.len)
173    object <- as.bitwhich(object[seq_len(vec.len)])
174  cat(if (give.head)paste("bitwhich ", if (give.length && n>1) paste(" [1:",n,"] ",sep=""), sep=""), paste(as.character(object), collapse=" ")," \n", sep="")
175  invisible()
176}
177
178
179
180#' Create bitwhich vector (skewed boolean)
181#'
182#' A bitwhich object represents a boolean filter like a \code{\link{bit}} object (NAs are not allowed)
183#' but uses a sparse representation suitable for very skewed (asymmetric) selections.
184#' Three extreme cases are represented with logical values, no length via logical(),
185#' all TRUE with TRUE and all FALSE with FALSE. All other selections are represented with
186#' positive or negative integers, whatever is shorter.
187#' This needs less RAM compared to \code{\link{logical}} (and often less than \code{\link{bit}} or \code{\link[=as.which]{which}}).
188#' Logical operations are fast if the selection is asymetric (only few or almost all selected).
189#'
190#' @param maxindex length of the vector
191#' @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.
192#' @param xempty what to assume about parameter \code{x} if \code{x=integer(0)}, typically \code{TRUE} or \code{FALSE}.
193#' @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.
194#' @param is.unsorted tuning: FALSE implies that \code{x} is already sorted and sorting is skipped
195#' @param has.dup tuning: FALSE implies that \code{x} has no duplicates
196#' @return an object of class 'bitwhich' carrying two attributes
197#' \describe{
198#'   \item{maxindex}{ see above }
199#'   \item{poslength}{ see above }
200#' }
201#' @seealso \code{\link{bitwhich_representation}},  \code{\link{as.bitwhich}}, \code{\link{bit}}
202#' @examples
203#' bitwhich()
204#' bitwhich(12)
205#' bitwhich(12, x=TRUE)
206#' bitwhich(12, x=3)
207#' bitwhich(12, x=-3)
208#' bitwhich(12, x=integer())
209#' bitwhich(12, x=integer(), xempty=TRUE)
210#' @export
211bitwhich <- function(maxindex=0L, x=NULL, xempty=FALSE, poslength=NULL, is.unsorted=TRUE, has.dup=TRUE){
212  maxindex <- as.integer(maxindex)
213  if (maxindex==0L){
214    if ((!is.null(poslength) && poslength) || (length(x) && (!is.logical(x) || x[[1]]==TRUE)))
215      stop("maxindex=0 given with poslength or x")
216    poslength <- 0L
217    ret <- logical()
218  }else{
219    stopifnot(maxindex>0L)
220    if (length(x)){
221      if (is.logical(x)){
222        if (length(x)!=1L || is.na(x)){
223          stop("logical x should be scalar FALSE or TRUE")
224        }else if (x){
225          if (is.null(poslength))
226            poslength <- maxindex
227          else if (poslength!=maxindex)
228            stop("x==TRUE implies poslength==maxindex")
229          ret <- copy_vector(TRUE)
230        }else{
231          if (is.null(poslength))
232            poslength <- 0L
233          else if (poslength!=0L)
234            stop("x==FALSE implies poslength==0")
235          ret <- copy_vector(FALSE)
236        }
237      }else{
238        x <- as.integer(x)
239        if (is.null(poslength)){
240          ret <- range_nanozero(x)
241          r <- getsetattr(ret, "range_na", NULL)
242          if (r[3]>0L)
243            stop("NA positions not allowed (neither positive nor negative)")
244          if (r[1]<0L){
245            if (r[2]>0L)
246              stop("mixed negative and positive subscripts not allowed")
247            if (-r[1] > maxindex)
248              stop("index value outside -maxindex..-1")
249          }else{
250            if (r[2] > maxindex)
251              stop("index value outside 1..maxindex")
252          }
253          if (is.unsorted)
254            ret <- bit_sort_unique(ret, na.last=NA, range_na=r)
255          else if (has.dup)
256            ret <- bit_unique(ret, na.rm = FALSE, range_na=r)
257          if (ret[1]<0){
258            poslength <- maxindex - length(ret)
259            if (poslength){
260              if (poslength <= maxindex%/%2L)
261                ret <- merge_rangediff(c(1L,maxindex), ret, revx=FALSE, revy=TRUE)
262            }else{
263              ret <- copy_vector(FALSE)
264            }
265          }else{
266            poslength <- length(ret)
267            if (poslength < maxindex){
268              if (poslength > maxindex%/%2L)
269                ret <- merge_rangediff(c(1L,maxindex), ret, revx=TRUE, revy=TRUE)
270            }else{
271              ret <- copy_vector(TRUE)
272            }
273          }
274        }else{
275          poslength <- as.integer(poslength)
276          if (poslength==0L)
277            ret <- copy_vector(FALSE)
278          else if (poslength==maxindex)
279            ret <- copy_vector(TRUE)
280          else{
281            if (length(x) > 2 && x[1] >= x[2])
282              stop("x is not sorted unique")
283            if ( x[1]<0L ){
284              if ( poslength != maxindex - length(x) )
285                stop("wrong poslength")
286              if (poslength <= maxindex%/%2L)
287                ret <- merge_rangediff(c(1L,maxindex), x, revx=FALSE, revy=TRUE)
288              else
289                ret <- copy_vector(x)
290            }else{
291              if ( poslength != length(x) )
292                stop("wrong poslength")
293              if (poslength > maxindex%/%2L)
294                ret <- merge_rangediff(c(1L,maxindex), x, revx=TRUE, revy=TRUE)
295              else
296                ret <- copy_vector(x)
297            }
298
299          }
300        }
301      }
302    }else{
303      if (is.null(poslength)){
304          if (!is.logical(xempty) || length(xempty)!=1 || is.na(xempty))
305            stop("xempty must be FALSE or TRUE")
306          if (xempty)
307            poslength <- maxindex
308          else
309            poslength <- 0L
310          ret <- copy_vector(xempty)
311      }else{
312        poslength <- as.integer(poslength)
313        if (poslength==0)
314          ret <- copy_vector(FALSE)
315        else if (poslength==maxindex)
316          ret <- copy_vector(TRUE)
317        else
318          stop("need x with extreme poslength")
319      }
320    }
321  }
322  setattributes(ret, list("maxindex" = maxindex, "poslength" = poslength, "class" = c("booltype","bitwhich")))
323  ret
324}
325
326
327
328#' Diagnose representation of bitwhich
329#'
330#' @param x a \code{\link{bitwhich}} object
331#' @return a scalar, one of \code{logical()}, \code{FALSE}, \code{TRUE}, \code{-1} or \code{1}
332#' @examples
333#' bitwhich_representation(bitwhich())
334#' bitwhich_representation(bitwhich(12,FALSE))
335#' bitwhich_representation(bitwhich(12,TRUE))
336#' bitwhich_representation(bitwhich(12, -3))
337#' bitwhich_representation(bitwhich(12, 3))
338#' @export
339bitwhich_representation <- function(x)
340{
341  .Call(C_R_bitwhich_representation, x)
342}
343
344
345
346#' Print method for bitwhich
347#'
348#' @param x a \code{\link{bitwhich}} object
349#' @param ... ignored
350#' @export
351print.bitwhich <- function(x, ...){
352  n <- length(x)
353  cat("bitwhich: ", sum(x), "/", n, " occupying only ", length(unclass(x)), " int32 in ", bitwhich_representation(x), " representation\n", sep="")
354  if (n>16){
355    y <- c(x[1:8], "..", x[(n-7L):n])
356    names(y) <- c(1:8, "", (n-7L):n)
357    print(y, quote=FALSE, ...)
358  }else if(n){
359    y <- c(x[])
360    names(y) <- c(1:n)
361    print(y, quote=FALSE, ...)
362  }
363}
364
365
366#' Boolean types
367#'
368#' The \code{\link{ordered}} factor \code{booltypes} ranks the boolean types.
369#'
370#' There are currently six boolean types, \code{booltypes} is an \code{\link{ordered}} vector with the following ordinal \code{\link{levels}} \describe{
371#' \item{nobool}{non-boolean types}
372#' \item{\code{\link{logical}}}{for representing any boolean data including \code{NA} }
373#' \item{\code{\link{bit}}}{for representing dense boolean data }
374#' \item{\code{\link{bitwhich}}}{for representing sparse (skewed) boolean data  }
375#' \item{\code{\link{which}}}{for representing sparse boolean data with few \code{TRUE}}
376## \item{\code{\link[ff]{hi}}}{hybrid-indexing, implemented in package \code{\link[ff]{ff}} }
377#' \item{\code{\link{ri}}}{range-indexing, for representing sparse boolean data with a single range of \code{TRUE} }
378#' }
379#' \code{booltypes} has a \code{\link{names}} attribute such that elements can be selected by name.
380#'
381#' @note do not rely on the internal integer codes of these levels, we might add-in \code{\link[ff]{hi}} later
382#' @seealso \code{\link{booltype}}, \code{\link{is.booltype}}, \code{\link{as.booltype}}
383#' @export
384booltypes <- c("nobool","logical","bit","bitwhich","which","ri")
385booltypes <- ordered(booltypes, levels=booltypes)
386names(booltypes) <- booltypes
387
388
389#' Diagnosing boolean types
390#'
391#' Specific methods for \code{booltype} are required, where non-unary methods can combine multiple bollean types, particularly boolean binary operators.
392#'
393#' Function \code{booltype} returns the boolean type of its argument.
394#' There are currently six boolean types, \code{booltypes} is an \code{\link{ordered}} vector with the following ordinal \code{\link{levels}} \describe{
395#' \item{nobool}{non-boolean types}
396#' \item{\code{\link{logical}}}{for representing any boolean data including \code{NA} }
397#' \item{\code{\link{bit}}}{for representing dense boolean data }
398#' \item{\code{\link{bitwhich}}}{for representing sparse (skewed) boolean data  }
399#' \item{\code{\link{which}}}{for representing sparse boolean data with few \code{TRUE}}
400## \item{\code{\link[ff]{hi}}}{hybrid-indexing, implemented in package \code{\link[ff]{ff}} }
401#' \item{\code{\link{ri}}}{range-indexing, for representing sparse boolean data with a single range of \code{TRUE} }
402#' }
403#' @param x an R object
404#'
405#' @return one scalar element of \code{\link{booltypes}} in case of 'nobool' it carries a name attribute with the data type.
406#' @note do not rely on the internal integer codes of these levels, we might add-in \code{\link[ff]{hi}} later
407#' @seealso \code{\link{booltypes}}, \code{\link{is.booltype}}, \code{\link{as.booltype}}
408#'
409#' @examples
410#' unname(booltypes)
411#' str(booltypes)
412#' sapply(list(double(),integer(),logical(),bit(),bitwhich(),as.which(),ri(1,2,3)), booltype)
413#' @export
414booltype <- function(x){
415  if (is.ri(x))
416    booltypes[["ri"]]
417  else if (is.hi(x))
418    booltypes[["hi"]]
419  else if (is.which(x))
420    booltypes[["which"]]
421  else if (is.bitwhich(x))
422    booltypes[["bitwhich"]]
423  else if (is.bit(x))
424    booltypes[["bit"]]
425  else if (is.logical(x))
426    booltypes[["logical"]]
427  else {
428    ret <- booltypes[["nobool"]]
429    names(ret) <- typeof(x)
430    ret
431  }
432}
433
434
435
436
437#' Testing for boolean types
438#'
439#' All \code{\link{booltypes}} including  \code{\link{logical}} except 'nobool' types are considered 'is.booltype'.
440#'
441#' @param x an R object
442#'
443#' @return logical scalar
444#' @seealso \code{\link{booltypes}}, \code{\link{booltype}}, \code{\link{as.booltype}}
445#'
446#' @examples
447#' sapply(list(double(),integer(),logical(),bit(),bitwhich(),as.which(),ri(1,2,3)), is.booltype)
448#' @export
449is.booltype <- function(x){
450  inherits(x, "booltype") || is.logical(x)
451}
452
453#' @describeIn is.booltype tests for \code{\link{bit}}
454#' @export
455is.bit <- function(x)
456  inherits(x, "bit")
457
458#' @describeIn is.booltype tests for \code{\link{bitwhich}}
459#' @export
460is.bitwhich <- function(x)
461  inherits(x, "bitwhich")
462
463#' @describeIn is.booltype tests for \code{\link[=as.which]{which}}
464#' @export
465is.which <- function(x)
466  inherits(x, "which")
467
468#' @describeIn is.booltype tests for \code{\link[ff]{hi}}
469#' @export
470is.hi <- function(x)
471  inherits(x, "hi")
472
473#' @describeIn is.booltype tests for \code{\link{ri}}
474#' @export
475is.ri <- function(x)
476  inherits(x, "ri")
477
478
479#' @describeIn as.booltype default method for as.booltype
480#' @export
481as.booltype.default <- function(x, booltype="logical", ...){
482  bt <- match.arg(as.character(booltype), as.character(booltypes))
483  do.call(switch(bt
484    , logical = "as.logical"
485    , bit     = "as.bit"
486    , bitwhich= "as.bitwhich"
487    , which= "as.which"
488    , hi= stop("not implemented for booltype hi")
489    , ri= "as.ri"
490    ), c(list(x, ...)))
491}
492
493
494#' @describeIn as.ri method to coerce \code{\link{ri}} to \code{\link{ri}}
495#' @export
496as.ri.ri <- function(x, ...)x
497
498#' @describeIn as.ri default method to coerce to \code{\link{ri}}
499#' @export
500as.ri.default <- function(x, ...){
501  r <- range.booltype(x)
502  n <- maxindex(x)
503  ri(r[[1]], r[[2]], n)
504}
505
506
507
508#' @describeIn maxindex default method for \code{maxindex}
509#' @export
510maxindex.default <-
511  function (x, ...)
512  {
513    mi <- attr(x, "maxindex")
514    if (is.null(mi))
515      NA_integer_
516    else mi
517  }
518
519#' @describeIn maxindex default method for \code{poslength}
520#' @export
521poslength.default <-
522  function (x, ...)
523  {
524    pl <- attr(x, "poslength")
525    if (is.null(pl))
526      NA_integer_
527    else pl
528  }
529
530
531#' @describeIn maxindex \code{maxindex} method for class \code{\link{logical}}
532#' @export
533maxindex.logical <- function(x, ...){
534  length(x)
535}
536
537#' @describeIn maxindex \code{poslength} method for class \code{\link{logical}}
538#' @export
539poslength.logical <- function(x, ...){
540  sum(x)
541}
542
543#' @describeIn maxindex \code{maxindex} method for class \code{\link{bit}}
544#' @export
545maxindex.bit <- function(x, ...){
546  length(x)
547}
548
549#' @describeIn maxindex \code{poslength} method for class \code{\link{bit}}
550#' @export
551poslength.bit <- function(x, ...)
552  sum(x, ...)
553
554#' @describeIn maxindex \code{maxindex} method for class \code{\link{bitwhich}}
555#' @export
556maxindex.bitwhich <- function(x, ...)
557  length(x, ...)
558
559#' @describeIn maxindex \code{poslength} method for class \code{\link{bitwhich}}
560#' @export
561poslength.bitwhich <- function(x, ...)
562  sum(x, ...)
563
564#' @describeIn maxindex \code{maxindex} method for class \code{\link[=as.which]{which}}
565#' @export
566maxindex.which <- function(x, ...){
567  attr(x, "maxindex")
568}
569
570#' @describeIn maxindex \code{poslength} method for class \code{\link[=as.which]{which}}
571#' @export
572poslength.which <- function(x, ...){
573  length(x)
574}
575
576#' @describeIn maxindex \code{maxindex} method for class \code{\link{ri}}
577#' @export
578maxindex.ri <- function(x, ...){
579  x[[3]]
580}
581
582#' @describeIn maxindex \code{poslength} method for class \code{\link{ri}}
583#' @export
584poslength.ri <- function(x, ...){
585  x[[2]] - x[[1]] + 1L
586}
587
588
589
590#' Getting and setting length of bit, bitwhich and ri objects
591#'
592#' Query the number of bits in a \code{\link{bit}} vector or change the number
593#' of bits in a bit vector. \cr Query the number of bits in a
594#' \code{\link{bitwhich}} vector or change the number of bits in a bit vector.
595#' \cr
596#'
597#' NOTE that the length does NOT reflect the number of selected (\code{TRUE})
598#' bits, it reflects the sum of both, \code{TRUE} and \code{FALSE} bits.
599#' Increasing the length of a \code{\link{bit}} object will set new bits to
600#' \code{FALSE}.  The behaviour of increasing the length of a
601#' \code{\link{bitwhich}} object is different and depends on the content of the
602#' object: \itemize{
603#' \item TRUE -- all included, new bits are set to \code{TRUE}
604#' \item positive integers -- some included, new bits are set to \code{FALSE}
605#' \item negative integers -- some excluded, new bits are set to \code{TRUE}
606#' \item FALSE -- all excluded:, new bits are set to \code{FALSE} } Decreasing the
607#' length of bit or bitwhich removes any previous information about the status
608#' bits above the new length.
609#'
610#' @name length.bit
611#' @param x a \code{\link{bit}}, \code{\link{bitwhich}} or \code{\link{ri}}
612#' object
613#' @param value the new number of bits
614#' @return the length A bit vector with the new length
615#' @author Jens Oehlschlägel
616#' @seealso \code{\link{length}}, \code{\link[=sum.bit]{sum}},
617#' \code{\link{poslength}}, \code{\link{maxindex}}
618#' @keywords classes logic
619#' @examples
620#'
621#'   stopifnot(length(ri(1, 1, 32))==32)
622#'
623#'   x <- as.bit(ri(32, 32, 32))
624#'   stopifnot(length(x)==32)
625#'   stopifnot(sum(x)==1)
626#'   length(x) <- 16
627#'   stopifnot(length(x)==16)
628#'   stopifnot(sum(x)==0)
629#'   length(x) <- 32
630#'   stopifnot(length(x)==32)
631#'   stopifnot(sum(x)==0)
632#'
633#'   x <- as.bit(ri(1, 1, 32))
634#'   stopifnot(length(x)==32)
635#'   stopifnot(sum(x)==1)
636#'   length(x) <- 16
637#'   stopifnot(length(x)==16)
638#'   stopifnot(sum(x)==1)
639#'   length(x) <- 32
640#'   stopifnot(length(x)==32)
641#'   stopifnot(sum(x)==1)
642#'
643#'   x <- as.bitwhich(bit(32))
644#'   stopifnot(length(x)==32)
645#'   stopifnot(sum(x)==0)
646#'   length(x) <- 16
647#'   stopifnot(length(x)==16)
648#'   stopifnot(sum(x)==0)
649#'   length(x) <- 32
650#'   stopifnot(length(x)==32)
651#'   stopifnot(sum(x)==0)
652#'
653#'   x <- as.bitwhich(!bit(32))
654#'   stopifnot(length(x)==32)
655#'   stopifnot(sum(x)==32)
656#'   length(x) <- 16
657#'   stopifnot(length(x)==16)
658#'   stopifnot(sum(x)==16)
659#'   length(x) <- 32
660#'   stopifnot(length(x)==32)
661#'   stopifnot(sum(x)==32)
662#'
663#'   x <- as.bitwhich(ri(32, 32, 32))
664#'   stopifnot(length(x)==32)
665#'   stopifnot(sum(x)==1)
666#'   length(x) <- 16
667#'   stopifnot(length(x)==16)
668#'   stopifnot(sum(x)==0)
669#'   length(x) <- 32
670#'   stopifnot(length(x)==32)
671#'   stopifnot(sum(x)==0)
672#'
673#'   x <- as.bitwhich(ri(2, 32, 32))
674#'   stopifnot(length(x)==32)
675#'   stopifnot(sum(x)==31)
676#'   length(x) <- 16
677#'   stopifnot(length(x)==16)
678#'   stopifnot(sum(x)==15)
679#'   length(x) <- 32
680#'   stopifnot(length(x)==32)
681#'   stopifnot(sum(x)==31)
682#'
683#'   x <- as.bitwhich(ri(1, 1, 32))
684#'   stopifnot(length(x)==32)
685#'   stopifnot(sum(x)==1)
686#'   length(x) <- 16
687#'   stopifnot(length(x)==16)
688#'   stopifnot(sum(x)==1)
689#'   length(x) <- 32
690#'   stopifnot(length(x)==32)
691#'   stopifnot(sum(x)==1)
692#'
693#'   x <- as.bitwhich(ri(1, 31, 32))
694#'   stopifnot(length(x)==32)
695#'   stopifnot(sum(x)==31)
696#'   message("NOTE the change from 'some excluded' to 'all excluded' here")
697#'   length(x) <- 16
698#'   stopifnot(length(x)==16)
699#'   stopifnot(sum(x)==16)
700#'   length(x) <- 32
701#'   stopifnot(length(x)==32)
702#'   stopifnot(sum(x)==32)
703#'
704#' @export
705length.bit <- function(x)
706  virtual(x)$Length
707
708#' @rdname length.bit
709#' @export
710"length<-.bit" <- function(x, value){
711  value <- as.integer(value)
712  vattr <- attr(x, "virtual")
713  oldvalue <- attr(vattr, "Length")
714  if (value!=oldvalue){
715    pattr <- attr(x, "physical")
716    cl <- oldClass(x)
717    oldn <- get_length(x)
718    dn <- value %% .BITS
719    if (dn){
720      n <- value %/% .BITS + 1L
721    }else{
722      n <- value %/% .BITS
723    }
724    if (oldn<n){
725      ret <- integer(n)
726      ret[seq_len(oldn)] <- x
727    }else if (n<oldn){
728      ret <- unclass(x)[seq_len(n)]
729    }else{
730      ret <- copy_vector(x)
731    }
732    if (dn && value<oldvalue){
733      .Call(C_R_bit_set_logical, ret, FALSE, c(value+1L, n*.BITS))
734    }
735    attr(vattr, "Length") <- value
736    setattributes(ret, list("physical" = pattr, "virtual" = vattr, "class" = cl))
737    ret
738  }else
739    x
740}
741
742
743#' @rdname length.bit
744#' @export
745length.bitwhich <- function(x)
746  attr(x, "maxindex")
747
748#' @rdname length.bit
749#' @export
750"length<-.bitwhich" <- function(x, value){
751  if (value!=length(x)){
752    value <- as.integer(value)
753    a <- attributes(x)
754    if (value){
755      if (is.integer(x)){
756          oldClass(x) <- NULL
757          if (x[1]>0){
758            ret <- x[x <= value]
759            l <- length(ret)
760            if (l==0)
761              ret <- copy_vector(FALSE)
762            else if (l==value)
763              ret <- copy_vector(TRUE)
764            else if (l>(value%/%2L))
765              ret <- merge_rangediff(c(-value,-1L), ret, revy=TRUE)
766          }else{
767            ret <- x[x >= -value]
768            l <- length(ret)
769            if (l==0)
770              ret <- copy_vector(TRUE)
771            else if (l==value)
772              ret <- copy_vector(FALSE)
773            else if (!((value-l)>(value%/%2L)))
774              ret <- merge_rangediff(c(1L,value), ret, revy=TRUE)
775            l <- value - l
776          }
777        }else{
778          if (length(x) && x){
779            ret <- bitwhich(value, x=TRUE, poslength=value)
780            l <- value
781          }else{
782            ret <- bitwhich(value, x=FALSE, poslength=0L)
783            l <- 0L
784          }
785        }
786    }else{
787      ret <- bitwhich()
788      l <- 0L
789    }
790  }
791  a$maxindex <- value
792  a$poslength <- l
793  setattributes(ret, a)
794  ret
795}
796
797
798
799#' Concatenating booltype vectors
800#'
801#' Creating new boolean vectors by concatenating boolean vectors
802#'
803#' @param \dots \code{\link{booltype}} vectors
804#' @return a vector with the lowest input \code{\link{booltype}} (but not lower than\code{\link{logical}})
805#' @author Jens Oehlschlägel
806#' @seealso \code{\link{c}}, \code{\link{bit}} , \code{\link{bitwhich}},  , \code{\link{which}}
807#' @keywords classes logic
808#' @examples
809#'  c(bit(4), !bit(4))
810#'  c(bit(4), !bitwhich(4))
811#'  c(bitwhich(4), !bit(4))
812#'  c(ri(1,2,4), !bit(4))
813#'  c(bit(4), !logical(4))
814#'  message("logical in first argument does not dispatch: c(logical(4), bit(4))")
815#'  c.booltype(logical(4), !bit(4))
816#'
817#' @export c.booltype
818#' @export
819c.booltype <- function(...){
820  l <- list(...)
821  bt <- sapply(l, booltype)
822  # xx TEMPORARY WORKAROND: work around a bug in sapply which destroys ordered levels
823  class(bt) <- c("ordered", "factor")
824  bt <- max(booltypes[["logical"]], min(bt, booltypes[["bitwhich"]]))
825  bt <- as.character(bt)
826  f <- list(logical=as.logical, bit=as.bit, bitwhich=as.bitwhich, which=as.which)[[bt]]
827  l <- lapply(l, f)
828  do.call(switch(bt
829 , logical="c"
830 , bit="c.bit"
831 , bitwhich="c.bitwhich"
832  ),  l)
833}
834
835#' @rdname c.booltype
836#' @export
837c.bit <- function(...){
838  l <- list(...)
839  nl <- length(l)
840  nold <- sapply(l, length)
841  nnew <- sum(nold)
842  ncum <- cumsum(nold)
843  offsets <- c(0L, ncum[-length(ncum)])
844  x <- bit(nnew)
845  for (i in seq_len(nl)){
846    b <- as.bit(l[[i]])
847    .Call(C_R_bit_shiftcopy, bsource_=b, btarget_=x, otarget_=offsets[i], n_=nold[i])
848  }
849  x
850}
851
852#' @rdname c.booltype
853#' @export
854c.bitwhich <- function(...){
855  l <- list(...)
856  if (length(l)==1)
857    l[[1]]
858  else
859    as.bitwhich(do.call("c", lapply(l, as.bit)))
860}
861
862
863#' Reversing bit and bitwhich vectors
864#'
865#' Creating new bit or bitwhich by reversing such vectors
866#'
867#' @name rev.booltype
868#' @param x bit or bitwhich object
869#' @return An object of class 'bit' or 'bitwhich'
870#' @author Jens Oehlschlägel
871#' @seealso \code{\link{rev}}, \code{\link{bit}} , \code{\link{bitwhich}}
872#' @keywords classes logic
873#' @examples
874#'
875#'  rev(as.bit(c(FALSE,TRUE)))
876#'  rev(as.bitwhich(c(FALSE,TRUE)))
877NULL
878
879#' @rdname rev.booltype
880#' @export
881rev.bit <- function(x){
882  if (length(x)){
883    x <- .Call(C_R_bit_reverse, x, bit(length(x)))
884  }
885  x
886}
887
888#' @rdname rev.booltype
889#' @export
890rev.bitwhich <- function(x){
891  n <- length(x)
892  if (is.logical(x)){
893    ret <- bitwhich(n, copy_vector(x), poslength=sum(x))
894  }else{
895    y <- bitwhich_representation(x)
896    if (n < .Machine$integer.max){
897      if (y[1]<0)
898        ret <- bitwhich(n, -(n+1L)-reverse_vector(x), poslength=sum(x))
899      else
900        ret <- bitwhich(n, (n+1L)-reverse_vector(x), poslength=sum(x))
901    }else{
902      if (y[1]<0)
903        ret <- bitwhich(n, -n-reverse_vector(x)-1L, poslength=sum(x))
904      else
905        ret <- bitwhich(n, n-reverse_vector(x)+1L, poslength=sum(x))
906    }
907  }
908  ret
909}
910
911
912#' Replicating bit and bitwhich vectors
913#'
914#' Creating new bit or bitwhich by recycling such vectors
915#'
916#' @name rep.booltype
917#' @param x bit or bitwhich object
918#' @param times number of replications
919#' @param length.out final length of replicated vector (dominates times)
920#' @param \dots not used
921#' @return An object of class 'bit' or 'bitwhich'
922#' @author Jens Oehlschlägel
923#' @seealso \code{\link{rep}}, \code{\link{bit}} , \code{\link{bitwhich}}
924#' @keywords classes logic
925#' @examples
926#'
927#'  rep(as.bit(c(FALSE,TRUE)), 2)
928#'  rep(as.bit(c(FALSE,TRUE)), length.out=7)
929#'  rep(as.bitwhich(c(FALSE,TRUE)), 2)
930#'  rep(as.bitwhich(c(FALSE,TRUE)), length.out=1)
931NULL
932
933#' @rdname rep.booltype
934#' @export
935rep.bit <- function(x, times = 1L, length.out = NA, ...){
936  if (length(times)>1L)
937    stop("only scalar times supported")
938  if (is.na(length.out))
939    length.out <- length(x)*as.integer(times)
940  else
941    length.out <- as.integer(length.out)
942  ret <- bit(length.out)
943  .Call(C_R_bit_recycle, ret, x)
944}
945
946#' @rdname rep.booltype
947#' @export
948rep.bitwhich <- function(x, times = 1L, length.out = NA, ...){
949  as.bitwhich(rep(as.bit(x), times=times, length.out=as.integer(length.out), ...))
950}
951
952
953#' @describeIn as.bit method to coerce to \code{\link{bit}} (zero length) from \code{\link{NULL}}
954#' @export
955as.bit.NULL <- function(x, ...){
956  bit(0L)
957}
958
959#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{bit}}
960#' @export
961as.bit.bit <- function(x, ...)
962  x
963
964#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{logical}}
965#' @export
966as.bit.logical <- function(x, ...){
967  n <- length(x)
968  b <- bit(n)
969  .Call(C_R_bit_set_logical, b, x, c(1L, n))
970}
971
972#' @describeIn as.bit method to coerce to \code{\link{bit}} from
973#'   \code{\link{integer}} (\code{0L} and \code{NA} become \code{FALSE},
974#'   everthing else becomes \code{TRUE})
975#' @examples as.bit(c(0L,1L,2L,-2L,NA))
976#' @export
977as.bit.integer <- function(x, ...){
978  n <- length(x)
979  b <- bit(n)
980  .Call(C_R_bit_set_integer, b, x, c(1L, n))
981}
982
983#' @describeIn as.bit method to coerce to \code{\link{bit}} from
984#'   \code{\link{double}} (\code{0} and \code{NA} become \code{FALSE}, everthing
985#'   else becomes \code{TRUE})
986#' @examples as.bit(c(0,1,2,-2,NA))
987#' @export
988as.bit.double <- function(x, ...){
989  n <- length(x)
990  b <- bit(n)
991  .Call(C_R_bit_set_integer, b, as.integer(x), c(1L, n))
992}
993
994#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{bitwhich}}
995#' @export
996as.bit.bitwhich <- function(x, ...){
997  if (length(x)){
998    b <- bit(length(x))
999    if (is.logical(x)){
1000      if (unclass(x))
1001        !b
1002      else
1003        b
1004    }else{
1005      .Call(C_R_bit_replace, b, x, TRUE)
1006    }
1007  }else{
1008    bit()
1009  }
1010}
1011
1012#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link[=as.which]{which}}
1013#' @export
1014as.bit.which <- function(x, length=attr(x, "maxindex"), ...){
1015  if (is.na(length))
1016    stop("cannot coerce to bit from which object with unknown maxindex")
1017  b <- bit(length)
1018  .Call(C_R_bit_replace, b, x, TRUE)
1019}
1020
1021#' @describeIn as.bit method to coerce to \code{\link{bit}} from \code{\link{ri}}
1022#' @export
1023as.bit.ri <- function(x, ...){
1024  if (is.na(x[3]))
1025    stop("cannot coerce to bit from ri object with unknown maxindex")
1026  b <- bit(x[3])
1027  .Call(C_R_bit_set_logical, b, TRUE, x)
1028}
1029
1030
1031
1032#' Coercion from bit, bitwhich, which and ri to logical, integer, double
1033#'
1034#' Coercion from bit is quite fast because we use a double loop that fixes each
1035#' word in a processor register.
1036#'
1037#' @name CoercionToStandard
1038#' @param x an object of class \code{\link{bit}}, \code{\link{bitwhich}} or
1039#' \code{\link{ri}}
1040#' @param length length of the boolean vector (required for \code{as.logical.which})
1041#' @param \dots ignored
1042#' @return \code{\link{as.logical}} returns a vector of \code{FALSE, TRUE},
1043#' \code{\link{as.integer}} and \code{\link{as.double}} return a vector of
1044#' \code{0,1}.
1045#' @author Jens Oehlschlägel
1046#' @seealso \code{\link{CoercionToStandard}}, \code{\link{as.booltype}}, \code{\link{as.bit}}, \code{\link{as.bitwhich}}
1047#' , \code{\link{as.which}}, \code{\link{as.ri}}, \code{\link[ff]{as.hi}},  \code{\link[ff]{as.ff}}
1048#' @keywords classes logic
1049#' @examples
1050#'
1051#'   x <- ri(2, 5, 10)
1052#'   y <- as.logical(x)
1053#'   y
1054#'   stopifnot(identical(y, as.logical(as.bit(x))))
1055#'   stopifnot(identical(y, as.logical(as.bitwhich(x))))
1056#'
1057#'   y <- as.integer(x)
1058#'   y
1059#'   stopifnot(identical(y, as.integer(as.logical(x))))
1060#'   stopifnot(identical(y, as.integer(as.bit(x))))
1061#'   stopifnot(identical(y, as.integer(as.bitwhich(x))))
1062#'
1063#'   y <- as.double(x)
1064#'   y
1065#'   stopifnot(identical(y, as.double(as.logical(x))))
1066#'   stopifnot(identical(y, as.double(as.bit(x))))
1067#'   stopifnot(identical(y, as.double(as.bitwhich(x))))
1068NULL
1069
1070#' @rdname CoercionToStandard
1071#' @export
1072as.logical.bit <- function(x, ...){
1073  l <- logical(length(x))
1074  .Call(C_R_bit_get_logical, x, l, c(1L, length(x)))
1075}
1076
1077#' @rdname CoercionToStandard
1078#' @export
1079as.integer.bit <- function(x, ...){
1080  l <- integer(length(x))
1081  .Call(C_R_bit_get_integer, x, l, c(1L, length(x)))
1082}
1083
1084#' @rdname CoercionToStandard
1085#' @export
1086as.double.bit <- function(x, ...){
1087  l <- integer(length(x))
1088  as.double(.Call(C_R_bit_get_integer, x, l, c(1L, length(x))))
1089}
1090
1091#' @rdname CoercionToStandard
1092#' @export
1093as.integer.bitwhich <- function(x, ...){
1094  n <- length(x)
1095  if (is.logical(x)){
1096    if (sum(x)==n)
1097      rep(1L, n)
1098    else
1099      rep(0L, n)
1100  }else{
1101    ret <- integer(n)
1102    ret[x] <- 1L
1103    ret
1104  }
1105}
1106
1107#' @rdname CoercionToStandard
1108#' @export
1109as.double.bitwhich <- function(x, ...){
1110  n <- length(x)
1111  if (is.logical(x)){
1112    if (sum(x)==n)
1113      rep(1, n)
1114    else
1115      rep(0, n)
1116  }else{
1117    ret <- double(n)
1118    ret[x] <- 1
1119    ret
1120  }
1121}
1122
1123
1124#' @rdname CoercionToStandard
1125#' @export
1126as.logical.bitwhich <- function(x, ...){
1127  n <- length(x)
1128  p <- sum(x)
1129  if (p==0){
1130    rep(FALSE, length(x))
1131  }else if (p==n){
1132    rep(TRUE, length(x))
1133  }else{
1134    ret <- logical(length(x))
1135    ret[x] <- TRUE
1136    ret
1137  }
1138}
1139
1140#' @rdname CoercionToStandard
1141#' @export
1142as.logical.ri <- function(x, ...){
1143  if (is.na(x[3]))
1144    stop("cannot coerce to logical from ri object with unknown maxindex")
1145  ret <- logical(x[3])
1146  ret[x[1]:x[2]] <- TRUE
1147  ret
1148}
1149
1150#' @rdname CoercionToStandard
1151#' @export
1152as.integer.ri <- function(x, ...){
1153  if (is.na(x[3]))
1154    stop("cannot coerce to integer from ri object with unknown maxindex")
1155  ret <- integer(x[3])
1156  ret[x[1]:x[2]] <- 1L
1157  ret
1158}
1159
1160#' @rdname CoercionToStandard
1161#' @export
1162as.double.ri <- function(x, ...){
1163  if (is.na(x[3]))
1164    stop("cannot coerce to integer from ri object with unknown maxindex")
1165  ret <- double(x[3])
1166  ret[x[1]:x[2]] <- 1
1167  ret
1168}
1169
1170
1171#' @rdname CoercionToStandard
1172#' @export
1173as.logical.which <- function(x, length=attr(x, "maxindex"), ...){
1174  if (is.na(length))
1175    stop("cannot coerce to logical from which object with unknown maxindex")
1176  l <- logical(length)
1177  l[x] <- TRUE
1178  l
1179}
1180
1181
1182#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link[=as.which]{which}}
1183#' @export
1184as.which.which <- function(x, maxindex=NA_integer_, ...)x
1185
1186#' @describeIn as.which method to coerce to zero length \code{\link[=as.which]{which}} from \code{\link{NULL}}
1187#' @export
1188as.which.NULL <- function(x, ...)structure(integer(), maxindex=0L, class=c("booltype", "which"))
1189
1190#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{numeric}}
1191#' @export
1192as.which.numeric <- function(x, maxindex=NA_integer_, ...){
1193  as.which(as.integer(x), maxindex=maxindex, ...)
1194}
1195
1196#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{integer}}
1197#' @export
1198as.which.integer <- function(x, maxindex=NA_integer_, is.unsorted=TRUE, has.dup=TRUE, ...){
1199  ret <- range_nanozero(as.integer(x))
1200  r <- getsetattr(ret, "range_na", NULL)
1201  if (length(ret)){
1202    if (r[3]>0L)
1203      stop("NA positions not allowed (neither positive nor negative)")
1204    if (r[1]<0L){
1205      if (r[2]>0L)
1206        stop("mixed negative and positive subscripts not allowed")
1207      if (is.na(maxindex))
1208        stop("need maxindex with negative subscripts")
1209      else if (-r[1] > maxindex)
1210        stop("index value outside -maxindex..-1")
1211    }else{
1212      if (!is.na(maxindex) && r[2] > maxindex)
1213        stop("index value outside 1..maxindex")
1214    }
1215    if (is.unsorted)
1216      ret <- bit_sort_unique(ret, na.last=NA, range_na=r, has.dup=has.dup)
1217    else if (has.dup)
1218      ret <- bit_unique(ret, na.rm = FALSE, range_na=r)
1219    if (r[1]<0L)
1220      ret <- merge_rangediff(c(1L,maxindex), ret, revx=FALSE, revy=TRUE)
1221  }
1222  setattributes(ret, list("maxindex" = maxindex, "class" = c("booltype", "which")))
1223  ret
1224}
1225
1226#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{logical}}
1227#' @export
1228as.which.logical <- function(x, ...){
1229  ret <- which(x)
1230  setattributes(ret, list("maxindex" = as.integer(length(x)), "class" = c("booltype", "which")))
1231  ret
1232}
1233
1234#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{ri}}
1235#' @export
1236as.which.ri <- function(x, ...){
1237  ret <- x[1]:x[2]
1238  setattributes(ret, list("maxindex" = as.integer(x[3]), "class" = c("booltype", "which")))
1239  ret
1240}
1241
1242#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{bit}}
1243#' @export
1244as.which.bit <- function(x, range=NULL, ...){
1245  maxindex <- length(x)
1246  if (is.null(range))
1247    range <- c(1L, maxindex)
1248  else{
1249    range <- as.integer(range[1:2])
1250    if (range[1]<1L || range[2]>maxindex)
1251      stop("illegal range")
1252  }
1253  s <- sum(x, range=range)
1254  n <- range[2] - range[1] + 1L
1255  if (s==0L){
1256    ret <- integer()
1257  }else if (s==n){
1258    #ret <- as.integer(seq.int(from=range[1], to=range[2], by=1))
1259    ret <- merge_rangediff(range, integer())
1260  }else
1261    ret <- .Call(C_R_bit_which, x, s, range, negative=FALSE)
1262  setattributes(ret, list("maxindex" = as.integer(maxindex), "class" = c("booltype", "which")))
1263  ret
1264}
1265
1266#' @describeIn as.which method to coerce to \code{\link[=as.which]{which}} from \code{\link{bitwhich}}
1267#' @export
1268as.which.bitwhich <- function(x, ...){
1269  maxindex <- length(x)
1270  if (is.logical(x)){
1271    if (maxindex && unclass(x))
1272      ret <- seq_len(maxindex)
1273    else
1274      ret <- integer()
1275  }else{
1276    if (unclass(x)[[1]]<0)
1277      ret <- merge_rangediff(c(1L,maxindex), x, revx=FALSE, revy=TRUE)
1278    else
1279      ret <- copy_vector(x)
1280  }
1281  setattributes(ret, list("maxindex" = as.integer(maxindex), "class" = c("booltype", "which")))
1282  ret
1283}
1284
1285
1286#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} (zero length) from \code{\link{NULL}}
1287#' @export
1288as.bitwhich.NULL <- function(x, ...){
1289  bitwhich()
1290}
1291
1292#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{bitwhich}}
1293#' @export
1294as.bitwhich.bitwhich <- function(x, ...){
1295  x
1296}
1297
1298#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link[=as.which]{which}}
1299#' @export
1300as.bitwhich.which <- function(x, maxindex=attr(x, "maxindex"), ...){
1301  if (is.na(maxindex))
1302    stop("need maxindex")
1303  if (maxindex==0)
1304    bitwhich()
1305  else{
1306    poslength <- length(x)
1307    if (poslength==0)
1308      bitwhich(maxindex, FALSE, poslength)
1309    else if (poslength==maxindex)
1310      bitwhich(maxindex, TRUE, poslength)
1311    else if (poslength>(maxindex%/%2L)){
1312      bitwhich(maxindex, merge_rangediff(c(1L,maxindex), x, revx=TRUE, revy=TRUE), poslength=poslength)
1313    }else{
1314      bitwhich(maxindex, x, poslength=poslength)
1315    }
1316  }
1317}
1318
1319#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{ri}}
1320#' @export
1321as.bitwhich.ri <- function(x, ...){
1322  maxindex <- length(x)
1323  if (is.na(maxindex))
1324    stop("you must provide maxindex with ri() in as.bitwhich.ri()")
1325  # ri selects at least one element,
1326  # hence maxindex>0 and poslength>0
1327  poslength <- sum(x)
1328  if (poslength==maxindex)
1329    bitwhich(maxindex, TRUE, poslength=poslength)
1330  else if (poslength>(maxindex%/%2L)){
1331    if (x[1]>1L) b <- (-x[1]+1L):(-1) else b <- integer()
1332    if (x[2]<maxindex) a <- (-maxindex):(-x[2]-1L) else a <- integer()
1333    bitwhich(maxindex, c(a,b), poslength=poslength)
1334  }else{
1335    bitwhich(maxindex, x[1]:x[2], poslength=poslength)
1336  }
1337}
1338
1339
1340
1341#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from
1342#'   \code{\link{integer}} (\code{0} and \code{NA} become \code{FALSE}, everthing
1343#'   else becomes \code{TRUE})
1344#' @examples as.bitwhich(c(0L,1L,2L,-2L,NA))
1345#' @export
1346as.bitwhich.integer <- function(x, poslength=NULL, ...)
1347  as.bitwhich(as.logical(x), poslength=poslength, ...)
1348
1349
1350#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from
1351#'   \code{\link{double}} (\code{0} and \code{NA} become \code{FALSE}, everthing
1352#'   else becomes \code{TRUE})
1353#' @examples as.bitwhich(c(0,1,2,-2,NA))
1354#' @export
1355as.bitwhich.double <- as.bitwhich.integer
1356
1357
1358#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{logical}}
1359#' @export
1360as.bitwhich.logical <- function(x, poslength=NULL, ...){
1361  maxindex <- length(x)
1362  if (maxindex==0)
1363    bitwhich()
1364  else{
1365    if (is.null(poslength))
1366      poslength <- sum(x, na.rm=TRUE)
1367    else
1368      if(poslength>maxindex)
1369        stop("poslength > maxindex")
1370    if (poslength==0)
1371      bitwhich(maxindex, FALSE, poslength=poslength)
1372    else if (poslength==maxindex)
1373      bitwhich(maxindex, TRUE, poslength=poslength)
1374    else if (poslength>(maxindex%/%2L)){
1375      as.bitwhich(as.bit(x), poslength=poslength)
1376    }else{
1377      bitwhich(maxindex, which(x), poslength=poslength)
1378    }
1379  }
1380}
1381
1382
1383#' @describeIn as.bitwhich method to coerce to \code{\link{bitwhich}} from \code{\link{bit}}
1384#' @export
1385as.bitwhich.bit <- function(x, range=NULL, poslength=NULL, ...){
1386  maxindex <- length(x)
1387  if (maxindex){
1388    if (is.null(range))
1389      range <- c(1L, maxindex)
1390    else{
1391      range <- as.integer(range[1:2])
1392      if (range[1]<1L || range[2]>maxindex)
1393        stop("illegal range")
1394    }
1395    if (is.null(poslength))
1396      poslength <- sum(x, range=range, na.rm=TRUE)
1397    else
1398      if(poslength>maxindex)
1399        stop("poslength > maxindex")
1400    if (poslength==0)
1401      bitwhich(maxindex, FALSE, poslength=poslength)
1402    else if (poslength==maxindex)
1403      bitwhich(maxindex, TRUE, poslength=poslength)
1404    else{
1405      if (poslength>(maxindex%/%2L)){
1406        bitwhich(maxindex, .Call(C_R_bit_which, x, maxindex - poslength, range=range, negative=TRUE), poslength=poslength)
1407      }else{
1408        bitwhich(maxindex, .Call(C_R_bit_which, x, poslength, range=range, negative=FALSE), poslength=poslength)
1409      }
1410    }
1411  }else bitwhich()
1412}
1413
1414
1415#' Test for NA in bit and bitwhich
1416#'
1417#' @name is.na.bit
1418#' @param x a \code{\link{bit}} or  \code{\link{bitwhich}} vector
1419#'
1420#' @return vector of same type with all elements \code{FALSE}
1421#' @seealso \code{\link{is.na}}
1422#'
1423#' @examples
1424#' is.na(bit(6))
1425#' is.na(bitwhich(6))
1426is.na.bit <- function(x)bit(length(x))
1427
1428#' @describeIn is.na.bit method for \code{\link{is.na}} from \code{\link{bitwhich}}
1429#' @export
1430is.na.bitwhich <- function(x)bitwhich(length(x))
1431
1432
1433#' @describeIn xor default method for \code{\link{xor}}
1434#' @export
1435xor.default <- function (x, y)
1436{
1437  cat("default\n")
1438  (x | y) & !(x & y)
1439}
1440
1441#' @describeIn xor \code{\link{logical}} method for \code{\link{xor}}
1442#' @export
1443xor.logical <- function(x,y){
1444    as.logical(x) != as.logical(y)
1445}
1446
1447#' @describeIn xor \code{\link{bit}} method for \code{\link{!}}
1448#' @export
1449"!.bit" <- function(x){
1450  if (length(x)){
1451    ret <- copy_vector(x)
1452    setattributes(ret, attributes(x))
1453    .Call(C_R_bit_not, ret)
1454  }else{
1455    x
1456  }
1457}
1458
1459#' @describeIn xor \code{\link{bit}} method for \code{\link{&}}
1460#' @export
1461"&.bit" <- function(e1, e2){
1462  n <- c(length(e1), length(e2))
1463  if (any(n==0L))
1464    return(bit())
1465  if(n[1]!=n[2])
1466    stop("length(e1) != length(e2)")
1467  e1 <- as.bit(e1)
1468  e2 <- as.bit(e2)
1469  ret <- bit(n[1])
1470  .Call(C_R_bit_and, e1, e2, ret)
1471}
1472
1473#' @describeIn xor \code{\link{bit}} method for \code{\link{|}}
1474#' @export
1475"|.bit" <- function(e1, e2){
1476  n <- c(length(e1), length(e2))
1477  if (any(n==0L))
1478    return(bit())
1479  if(n[1]!=n[2])
1480    stop("length(e1) != length(e2)")
1481  e1 <- as.bit(e1)
1482  e2 <- as.bit(e2)
1483  ret <- bit(n[1])
1484  .Call(C_R_bit_or, e1, e2, ret)
1485}
1486
1487#' @describeIn xor \code{\link{bit}} method for \code{\link{==}}
1488#' @export
1489"==.bit" <- function(e1, e2){
1490  n <- c(length(e1), length(e2))
1491  if (any(n==0L))
1492    return(bit())
1493  if(n[1]!=n[2])
1494    stop("length(e1) != length(e2)")
1495  e1 <- as.bit(e1)
1496  e2 <- as.bit(e2)
1497  ret <- bit(n[1])
1498  .Call(C_R_bit_equal, e1, e2, ret)
1499}
1500
1501#' @describeIn xor \code{\link{bit}} method for \code{\link{!=}}
1502#' @export
1503"!=.bit" <- function(e1, e2){
1504  n <- c(length(e1), length(e2))
1505  if (any(n==0L))
1506    return(bit())
1507  if(n[1]!=n[2])
1508    stop("length(e1) != length(e2)")
1509  e1 <- as.bit(e1)
1510  e2 <- as.bit(e2)
1511  ret <- bit(n[1])
1512  .Call(C_R_bit_xor, e1, e2, ret)
1513}
1514
1515#' @describeIn xor \code{\link{bit}} method for \code{\link{xor}}
1516#' @export
1517"xor.bit" <- function(x, y){
1518  n <- c(length(x), length(y))
1519  if (any(n==0L))
1520    return(bit())
1521  if(n[1]!=n[2])
1522    stop("length(x) != length()")
1523  x <- as.bit(x)
1524  y <- as.bit(y)
1525  ret <- bit(n[1])
1526  .Call(C_R_bit_xor, x, y, ret)
1527}
1528
1529
1530#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{!}}
1531#' @export
1532"!.bitwhich" <- function(x){
1533  n <- length(x)
1534  p <- sum(x)
1535  if (is.logical(x)){
1536    if (n==0)
1537      bitwhich()
1538    else if (p==n){
1539      bitwhich(maxindex=n, FALSE, poslength=0L)
1540    }else{
1541      bitwhich(maxindex=n, TRUE, poslength=n)
1542    }
1543  }else{
1544    #bitwhich(maxindex=n, -rev(unclass(x)), poslength=n-p, is.unsorted = FALSE, has.dup=FALSE)
1545    bitwhich(maxindex=n, copy_vector(x, revx=TRUE), poslength=n-p, is.unsorted = FALSE, has.dup=FALSE)
1546  }
1547}
1548
1549#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{&}}
1550#' @export
1551"&.bitwhich" <- function(e1, e2){
1552  e1 <- as.bitwhich(e1)
1553  e2 <- as.bitwhich(e2)
1554  n <- c(length(e1), length(e2))
1555  if (any(n==0L))
1556    return(bitwhich())
1557  if(n[1]!=n[2])
1558    stop("length(e1) != length(e2)")
1559  p <- c(sum(e1), sum(e2))
1560  if (p[1]==0 || p[2]==0)
1561    return(bitwhich(n[1], FALSE, 0L))
1562  if (p[1]==n[1])
1563    return(e2)
1564  if (p[2]==n[2])
1565    return(e1)
1566  #negative <- p>(n%/%2L)
1567  negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
1568  if (negative[1]){
1569    if (negative[2]){
1570      ret <- merge_union(e1, e2, method="exact")
1571      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1572    }else{
1573      ret <- merge_setdiff(e2, e1, revy=TRUE, method="exact")
1574      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1575    }
1576  }else{
1577    if (negative[2]){
1578      ret <- merge_setdiff(e1, e2, revy=TRUE, method="exact")
1579      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1580    }else{
1581      ret <- merge_intersect(e1, e2, method="exact")
1582      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1583    }
1584  }
1585}
1586
1587
1588#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{|}}
1589#' @export
1590"|.bitwhich" <- function(e1, e2){
1591  e1 <- as.bitwhich(e1)
1592  e2 <- as.bitwhich(e2)
1593  n <- c(length(e1), length(e2))
1594  if (any(n==0L))
1595    return(bitwhich())
1596  if(n[1]!=n[2])
1597    stop("length(e1) != length(e2)")
1598  p <- c(sum(e1), sum(e2))
1599  if (p[1]==n[1] || p[2]==n[2])
1600    return(bitwhich(n[1], TRUE, n[1]))
1601  if (p[1]==0)
1602    return(e2)
1603  if (p[2]==0)
1604    return(e1)
1605  #negative <- p>(n%/%2L)
1606  negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
1607  if (negative[1]){
1608    if (negative[2]){
1609      ret <- merge_intersect(e1, e2, method="exact")
1610      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1611    }else{
1612      ret <- merge_setdiff(e1, e2, revy=TRUE, method="exact")
1613      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1614    }
1615  }else{
1616    if (negative[2]){
1617      ret <- merge_setdiff(e2, e1, revy=TRUE, method="exact")
1618      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1619    }else{
1620      ret <- merge_union(e1, e2, method="exact")
1621      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1622    }
1623  }
1624}
1625
1626#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{==}}
1627#' @export
1628"==.bitwhich" <- function(e1, e2){
1629  e1 <- as.bitwhich(e1)
1630  e2 <- as.bitwhich(e2)
1631  n <- c(length(e1), length(e2))
1632  if (any(n==0L))
1633    return(bitwhich())
1634  if(n[1]!=n[2])
1635    stop("length(e1) != length(e2)")
1636  p <- c(sum(e1), sum(e2))
1637  if (p[1]==0)
1638    return(!e2)
1639  if (p[1]==n[1])
1640    return(e2)
1641  if (p[2]==0)
1642    return(!e1)
1643  if (p[2]==n[2])
1644    return(e1)
1645  #negative <- p>(n%/%2L)
1646  negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
1647  if (negative[1]){
1648    if (negative[2]){
1649      ret <- merge_symdiff(e1, e2, method = "exact")
1650      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1651    }else{
1652      ret <- merge_symdiff(e1, e2, revx=TRUE, method = "exact")
1653      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1654    }
1655  }else{
1656    if (negative[2]){
1657      ret <- merge_symdiff(e1, e2, revy=TRUE, method = "exact")
1658      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1659    }else{
1660      ret <- merge_symdiff(e1, e2, revx=TRUE, revy=TRUE, method = "exact")
1661      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1662    }
1663  }
1664}
1665
1666#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{!=}}
1667#' @export
1668"!=.bitwhich" <- function(e1, e2){
1669  e1 <- as.bitwhich(e1)
1670  e2 <- as.bitwhich(e2)
1671  n <- c(length(e1), length(e2))
1672  if (any(n==0L))
1673    return(bitwhich())
1674  if(n[1]!=n[2])
1675    stop("length(e1) != length(e2)")
1676  p <- c(sum(e1), sum(e2))
1677  if (p[1]==0)
1678    return(e2)
1679  if (p[1]==n[1])
1680    return(!e2)
1681  if (p[2]==0)
1682    return(e1)
1683  if (p[2]==n[2])
1684    return(!e1)
1685  #negative <- p>(n%/%2L)
1686  negative <- c(unclass(e1)[1]<0, unclass(e2)[1]<0)
1687  if (negative[1]){
1688    if (negative[2]){
1689      ret <- merge_symdiff(e1, e2, revx=TRUE, revy=TRUE, method = "exact")
1690      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1691    }else{
1692      ret <- merge_symdiff(e1, e2, revy=TRUE, method = "exact")
1693      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1694    }
1695  }else{
1696    if (negative[2]){
1697      ret <- merge_symdiff(e1, e2, revx=TRUE, method = "exact")
1698      bitwhich(maxindex=n[1], ret, poslength=n[1]-length(ret))
1699    }else{
1700      ret <- merge_symdiff(e1, e2, method = "exact")
1701      bitwhich(maxindex=n[1], ret, poslength=length(ret))
1702    }
1703  }
1704}
1705
1706#' @describeIn xor \code{\link{bitwhich}} method for \code{\link{xor}}
1707#' @export
1708"xor.bitwhich" <- function(x, y) x != y
1709
1710#' @describeIn xor \code{\link{booltype}} method for \code{\link{&}}
1711#' @export &.booltype
1712#' @export
1713"&.booltype" <- function(e1, e2){
1714  # align booltype between logical and bitwhich
1715  b1 <- booltype(e1)
1716  b2 <- booltype(e2)
1717  b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
1718  e1 <- as.booltype(e1, b)
1719  e2 <- as.booltype(e2, b)
1720  # align length
1721  n1 <- length(e1)
1722  n2 <- length(e2)
1723  if (n1 && n2){
1724    if (n1 < n2){
1725      if (n2%%n1)
1726        warning("longer object length is not a multiple of shorter object length")
1727      e1 <- rep(e1, length.out=n2)
1728      n1 <- n2
1729    }else if (n2 < n1){
1730      if (n1%%n2)
1731        warning("longer object length is not a multiple of shorter object length")
1732      e2 <- rep(e2, length.out=n1)
1733    }
1734  }
1735  # do the operation
1736  switch(  as.character(b)
1737         , "logical" = e1 & e2
1738         , "bit" = "&.bit"(e1, e2)
1739         , "bitwhich" = "&.bitwhich"(e1, e2)
1740  )
1741}
1742
1743#' @describeIn xor \code{\link{booltype}} method for \code{\link{|}}
1744#' @export |.booltype
1745#' @export
1746"|.booltype" <- function(e1, e2){
1747  # align booltype between logical and bitwhich
1748  b1 <- booltype(e1)
1749  b2 <- booltype(e2)
1750  b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
1751  e1 <- as.booltype(e1, b)
1752  e2 <- as.booltype(e2, b)
1753  # align length
1754  n1 <- length(e1)
1755  n2 <- length(e2)
1756  if (n1 && n2){
1757    if (n1 < n2){
1758      if (n2%%n1)
1759        warning("longer object length is not a multiple of shorter object length")
1760      e1 <- rep(e1, length.out=n2)
1761      n1 <- n2
1762    }else if (n2 < n1){
1763      if (n1%%n2)
1764        warning("longer object length is not a multiple of shorter object length")
1765      e2 <- rep(e2, length.out=n1)
1766    }
1767  }
1768  # do the operation
1769  switch(  as.character(b)
1770           , "logical" = e1 | e2
1771           , "bit" = "|.bit"(e1, e2)
1772           , "bitwhich" = "|.bitwhich"(e1, e2)
1773  )
1774}
1775
1776#' @describeIn xor \code{\link{booltype}} method for \code{\link{==}}
1777#' @export ==.booltype
1778#' @export
1779"==.booltype" <- function(e1, e2){
1780  # align booltype between logical and bitwhich
1781  b1 <- booltype(e1)
1782  b2 <- booltype(e2)
1783  b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
1784  e1 <- as.booltype(e1, b)
1785  e2 <- as.booltype(e2, b)
1786  # align length
1787  n1 <- length(e1)
1788  n2 <- length(e2)
1789  if (n1 && n2){
1790    if (n1 < n2){
1791      if (n2%%n1)
1792        warning("longer object length is not a multiple of shorter object length")
1793      e1 <- rep(e1, length.out=n2)
1794      n1 <- n2
1795    }else if (n2 < n1){
1796      if (n1%%n2)
1797        warning("longer object length is not a multiple of shorter object length")
1798      e2 <- rep(e2, length.out=n1)
1799    }
1800  }
1801  # do the operation
1802  switch(  as.character(b)
1803           , "logical" = e1 == e2
1804           , "bit" = "==.bit"(e1, e2)
1805           , "bitwhich" = "==.bitwhich"(e1, e2)
1806  )
1807}
1808
1809#' @describeIn xor \code{\link{booltype}} method for \code{\link{!=}}
1810#' @export !=.booltype
1811#' @export
1812"!=.booltype" <- function(e1, e2){
1813  # align booltype between logical and bitwhich
1814  b1 <- booltype(e1)
1815  b2 <- booltype(e2)
1816  b <- min(max(booltypes[["logical"]], min(b1,b2)), booltypes[["bitwhich"]])
1817  e1 <- as.booltype(e1, b)
1818  e2 <- as.booltype(e2, b)
1819  # align length
1820  n1 <- length(e1)
1821  n2 <- length(e2)
1822  if (n1 && n2){
1823    if (n1 < n2){
1824      if (n2%%n1)
1825        warning("longer object length is not a multiple of shorter object length")
1826      e1 <- rep(e1, length.out=n2)
1827      n1 <- n2
1828    }else if (n2 < n1){
1829      if (n1%%n2)
1830        warning("longer object length is not a multiple of shorter object length")
1831      e2 <- rep(e2, length.out=n1)
1832    }
1833  }
1834  # do the operation
1835  switch(  as.character(b)
1836           , "logical" = e1 != e2
1837           , "bit" = "!=.bit"(e1, e2)
1838           , "bitwhich" = "!=.bitwhich"(e1, e2)
1839  )
1840}
1841
1842#' @describeIn xor \code{\link{booltype}} method for \code{\link{xor}}
1843#' @export xor.booltype
1844#' @export
1845"xor.booltype" <- function(x, y){
1846  x != y
1847}
1848
1849
1850
1851#' Summaries of boolean vectors
1852#'
1853#' Fast aggregation functions for \code{\link{booltype}} vectors. namely \code{\link{bit}}, \code{\link{all}}, \code{\link{any}}, \code{\link{anyNA}},
1854#' \code{\link{min}}, \code{\link{max}}, \code{\link{range}},
1855#' \code{\link{sum}} and \code{\link{summary}}.
1856#' 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.
1857#' Note that the boolean summaries have meaning and return values differing from logical aggregation functions: they treat \code{NA} as \code{FALSE},
1858#' \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}.
1859#' 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.
1860#'
1861#' Summaries of \code{\link{bit}} vectors are quite fast because we use a double loop that fixes each
1862#' word in a processor register.  Furthermore we break out of looping as soon
1863#' as possible. Summaries of \code{\link{bitwhich}} vectors are even faster, if the selection is very skewed.
1864#'
1865#' @name Summaries
1866#' @param x an object of class bit or bitwhich
1867#' @param object an object of class bit
1868#' @param range a \code{\link{ri}} or an integer vector of length==2 giving a
1869#' range restriction for chunked processing
1870#' @param recursive formally required but not used
1871#' @param \dots formally required but not used
1872#' @return as expected
1873#' @author Jens Oehlschlägel
1874#' @seealso \code{\link{length}}
1875#' @keywords classes logic
1876#' @examples
1877#'
1878#'   l <- c(NA, FALSE, TRUE)
1879#'   b <- as.bit(l)
1880#'
1881#'   all(l)
1882#'   all(b)
1883#'   all(b, range=c(3,3))
1884#'   all.booltype(l, range=c(3,3))
1885#'
1886#'   min(l)
1887#'   min(b)
1888#'
1889#'   sum(l)
1890#'   sum(b)
1891#'
1892#'   summary(l)
1893#'   summary(b)
1894#'   summary.booltype(l)
1895NULL
1896
1897# xx MEMO: R CMD check --no-tests  --no-manual --no-vignettes bit
1898
1899#' @rdname Summaries
1900#' @export
1901all.bit <- function(x, range=NULL, ...){
1902  if (is.null(range))
1903    range <- c(1L, length(x))
1904  else{
1905    range <- as.integer(range[1:2])
1906    if (range[1]<1L || range[2]>length(x))
1907      stop("illegal range")
1908  }
1909  .Call(C_R_bit_all, x, range)
1910}
1911
1912#' @rdname Summaries
1913#' @export
1914any.bit <- function(x, range=NULL, ...){
1915  if (is.null(range))
1916    range <- c(1L, length(x))
1917  else{
1918    range <- as.integer(range[1:2])
1919    if (range[1]<1L || range[2]>length(x))
1920      stop("illegal range")
1921  }
1922  .Call(C_R_bit_any, x, range)
1923}
1924
1925#' @rdname Summaries
1926#' @export
1927anyNA.bit <- function(x
1928                      #, range=NULL
1929                      , recursive = FALSE)FALSE
1930
1931#' @rdname Summaries
1932#' @export
1933sum.bit <- function(x, range=NULL, ...){
1934  if (is.null(range))
1935    range <- c(1L, length(x))
1936  else{
1937    range <- as.integer(range[1:2])
1938    if (range[1]<1L || range[2]>length(x))
1939      stop("illegal range")
1940  }
1941  .Call(C_R_bit_sum, x, range)
1942}
1943
1944#' @rdname Summaries
1945#' @export
1946min.bit <- function(x, range=NULL, ...){
1947  if (is.null(range))
1948    range <- c(1L, length(x))
1949  else{
1950    range <- as.integer(range[1:2])
1951    if (range[1]<1L || range[2]>length(x))
1952      stop("illegal range")
1953  }
1954  .Call(C_R_bit_min, x, range)
1955}
1956
1957#' @rdname Summaries
1958#' @export
1959max.bit <- function(x, range=NULL, ...){
1960  if (is.null(range))
1961    range <- c(1L, length(x))
1962  else{
1963    range <- as.integer(range[1:2])
1964    if (range[1]<1L || range[2]>length(x))
1965      stop("illegal range")
1966  }
1967  .Call(C_R_bit_max, x, range)
1968}
1969
1970#' @rdname Summaries
1971#' @export
1972range.bit <- function(x, range=NULL, ...){
1973  if (is.null(range))
1974    range <- c(1L, length(x))
1975  else{
1976    range <- as.integer(range[1:2])
1977    if (range[1]<1L || range[2]>length(x))
1978      stop("illegal range")
1979  }
1980  ret <- integer(2)
1981  ret[1] <- .Call(C_R_bit_min, x, range)
1982  if (is.na(ret[1]))
1983    ret[2] <- NA_integer_
1984  else
1985    ret[2] <- .Call(C_R_bit_max, x, range)
1986  ret
1987}
1988
1989#' @rdname Summaries
1990#' @export
1991summary.bit <- function(object, range=NULL, ...){
1992  if (is.null(range))
1993    range <- c(1L, length(object))
1994  else{
1995    range <- as.integer(range[1:2])
1996    if (range[1]<1L || range[2]>length(object))
1997      stop("illegal range")
1998  }
1999  s <- sum(object, range=range)
2000  r <- range(object, range=range)
2001  c("FALSE"=range[2]-range[1]+1L-s, "TRUE"=s, "Min."=r[1], "Max."=r[2])
2002}
2003
2004
2005
2006#' @rdname Summaries
2007#' @export
2008all.bitwhich <- function(x, range=NULL, ...){
2009  if (is.null(range))
2010    attr(x, "poslength") == attr(x, "maxindex")
2011  else{
2012    y <- bitwhich_representation(x)
2013    range <- as.integer(range)
2014    if (is.logical(y)){
2015      if (y)
2016        TRUE
2017      else
2018        FALSE
2019    }else{
2020      if (y<0){
2021        all(merge_rangenotin(rx=range, y=x, revx=FALSE, revy=TRUE))
2022      }else{
2023        all(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
2024      }
2025    }
2026  }
2027}
2028
2029#' @rdname Summaries
2030#' @export
2031any.bitwhich <- function(x, range=NULL, ...){
2032  if (is.null(range))
2033    attr(x, "poslength") > 0L
2034  else{
2035    y <- bitwhich_representation(x)
2036    range <- as.integer(range)
2037    if (is.logical(y)){
2038      if (y)
2039        TRUE
2040      else
2041        FALSE
2042    }else{
2043      if (y<0){
2044        any(merge_rangenotin(rx=range, y=x, revx=FALSE, revy=TRUE))
2045      }else{
2046        any(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
2047      }
2048    }
2049  }
2050}
2051
2052#' @rdname Summaries
2053#' @export
2054anyNA.bitwhich <- function(x
2055                           #, range=NULL
2056                           , recursive = FALSE)FALSE
2057
2058#' @rdname Summaries
2059#' @export
2060sum.bitwhich <- function(x, range=NULL, ...){
2061  if (is.null(range))
2062    attr(x, "poslength")
2063  else{
2064    y <- bitwhich_representation(x)
2065    range <- as.integer(range)
2066    if (is.logical(y)){
2067      if (y)
2068        range[2] - range[1] + 1L
2069      else
2070        0L
2071    }else{
2072      if (y<0){
2073        sum(merge_rangenotin(rx=range, y=x, revx=FALSE, revy=TRUE))
2074      }else{
2075        sum(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
2076      }
2077    }
2078  }
2079}
2080
2081#' @rdname Summaries
2082#' @export
2083min.bitwhich <- function(x, range=NULL, ...){
2084  y <- bitwhich_representation(x)
2085  if (is.logical(y)){
2086    if (length(y) && y)
2087      1L
2088    else
2089      NA_integer_
2090  }else{
2091    if (is.null(range)){
2092      if (y<0L){
2093        merge_firstnotin(c(1L,length(x)), x, revy=TRUE)
2094      }else{
2095        merge_first(x)
2096      }
2097    }else{
2098      range <- as.integer(range)
2099      if (y<0L){
2100        merge_firstnotin(range, x, revy=TRUE)
2101      }else{
2102        merge_firstin(range, x)
2103      }
2104    }
2105  }
2106}
2107
2108#' @rdname Summaries
2109#' @export
2110max.bitwhich <- function(x, range=NULL, ...){
2111  y <- bitwhich_representation(x)
2112  if (is.logical(y)){
2113    if (length(y) && y)
2114      length(x)
2115    else
2116      NA_integer_
2117  }else{
2118    if (is.null(range)){
2119      if (y<0L){
2120        merge_lastnotin(c(1L,length(x)), x, revy=TRUE)
2121      }else{
2122        merge_last(x)
2123      }
2124    }else{
2125      range <- as.integer(range)
2126      if (y<0L){
2127        merge_lastnotin(range, x, revy=TRUE)
2128      }else{
2129        merge_lastin(range, x)
2130      }
2131    }
2132  }
2133}
2134
2135#' @rdname Summaries
2136#' @export
2137range.bitwhich <- function(x, range=NULL, ...){
2138  c(min(x, range=range, ...), max(x, range=range, ...))
2139}
2140
2141#' @rdname Summaries
2142#' @export
2143summary.bitwhich <- function(object, range=NULL, ...){
2144  n <- attr(object, "maxindex")
2145  p <- attr(object, "poslength")
2146  r <- range(object)
2147  c("FALSE"=n-p, "TRUE"=p, "Min."=r[1], "Max."=r[2])
2148}
2149
2150
2151
2152
2153#' @rdname Summaries
2154#' @export
2155all.which <- function(x, range=NULL, ...){
2156  if (is.null(range))
2157    length(x) == attr(x, "maxindex")
2158  else{
2159    range <- as.integer(range)
2160    all(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
2161  }
2162}
2163
2164#' @rdname Summaries
2165#' @export
2166any.which <- function(x, range=NULL, ...){
2167  if (is.null(range))
2168    length(x) > 0L
2169  else{
2170    range <- as.integer(range)
2171    any(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
2172  }
2173}
2174
2175#' @rdname Summaries
2176#' @export
2177anyNA.which <- function(x
2178                        #, range=NULL
2179                        , recursive = FALSE)FALSE
2180
2181#' @rdname Summaries
2182#' @export
2183sum.which <- function(x, range=NULL, ...){
2184  if (is.null(range))
2185    length(x)
2186  else{
2187    sum(merge_rangein(rx=range, y=x, revx=FALSE, revy=FALSE))
2188  }
2189}
2190
2191#' @rdname Summaries
2192#' @export
2193min.which <- function(x, range=NULL, ...){
2194  if (is.null(range)){
2195    merge_first(x)
2196  }else{
2197    range <- as.integer(range)
2198    merge_firstin(range, x)
2199  }
2200}
2201
2202#' @rdname Summaries
2203#' @export
2204max.which <- function(x, range=NULL, ...){
2205  if (is.null(range)){
2206    merge_last(x)
2207  }else{
2208    range <- as.integer(range)
2209    merge_lastin(range, x)
2210  }
2211}
2212
2213#' @rdname Summaries
2214#' @export
2215range.which <- function(x, range=NULL, ...){
2216  c(min(x, range=range, ...), max(x, range=range, ...))
2217}
2218
2219#' @rdname Summaries
2220#' @export
2221summary.which <- function(object, range=NULL, ...){
2222  n <- attr(object, "maxindex")
2223  p <- attr(object, "poslength")
2224  r <- range(object)
2225  c("FALSE"=n-p, "TRUE"=p, "Min."=r[1], "Max."=r[2])
2226}
2227
2228#' @rdname Summaries
2229#' @export all.booltype
2230#' @export
2231all.booltype <- function(x, range=NULL, ...){
2232  switch(as.character(booltype(x))
2233         , nobool=all.bit(as.bit(x), range=range, ...)
2234         , logical=all.bit(as.bit(x), range=range, ...)
2235         , bit=all.bit(x, range=range, ...)
2236         , bitwhich=all.bitwhich(x, range=range, ...)
2237         , which=all.bit(as.bit(x), range=range, ...)
2238         , hi=stop("not implemented")
2239         , ri=all.ri(x, range=range, ...)
2240  )
2241}
2242
2243#' @rdname Summaries
2244#' @export any.booltype
2245#' @export
2246any.booltype <- function(x, range=NULL, ...){
2247  switch(as.character(booltype(x))
2248         , nobool=any.bit(as.bit(x), range=range, ...)
2249         , logical=any.bit(as.bit(x), range=range, ...)
2250         , bit=any.bit(x, range=range, ...)
2251         , bitwhich=any.bitwhich(x, range=range, ...)
2252         , which=any.bit(as.bit(x), range=range, ...)
2253         , hi=stop("not implemented")
2254         , ri=any.ri(x, range=range, ...)
2255  )
2256}
2257
2258#' @rdname Summaries
2259#' @export anyNA.booltype
2260#' @export
2261anyNA.booltype <- function(x
2262                           #, range=NULL
2263                           , ...){
2264  switch(as.character(booltype(x))
2265         , nobool=anyNA.bit(as.bit(x)
2266                            #, range=range
2267                            , ...)
2268         , logical=anyNA.bit(as.bit(x)
2269                             #, range=range
2270                             , ...)
2271         , bit=anyNA.bit(x
2272                         #, range=range
2273                         , ...)
2274         , bitwhich=anyNA.bitwhich(x
2275                                   #, range=range
2276                                   , ...)
2277         , which=anyNA.bit(as.bit(x)
2278                           #, range=range
2279                           , ...)
2280         , hi=stop("not implemented")
2281         , ri=anyNA.ri(x
2282                       #, range=range
2283                       , ...)
2284  )
2285}
2286
2287
2288#' @rdname Summaries
2289#' @export sum.booltype
2290#' @export
2291sum.booltype <- function(x, range=NULL, ...){
2292  switch(as.character(booltype(x))
2293         , nobool=sum.bit(as.bit(x), range=range, ...)
2294         , logical=sum.bit(as.bit(x), range=range, ...)
2295         , bit=sum.bit(x, range=range, ...)
2296         , bitwhich=sum.bitwhich(x, range=range, ...)
2297         , which=sum.bit(as.bit(x), range=range, ...)
2298         , hi=stop("not implemented")
2299         , ri=sum.ri(x, range=range, ...)
2300  )
2301}
2302
2303#' @rdname Summaries
2304#' @export min.booltype
2305#' @export
2306min.booltype <- function(x, range=NULL, ...){
2307  switch(as.character(booltype(x))
2308         , nobool=min.bit(as.bit(x), range=range, ...)
2309         , logical=min.bit(as.bit(x), range=range, ...)
2310         , bit=min.bit(x, range=range, ...)
2311         , bitwhich=min.bitwhich(x, range=range, ...)
2312         , which=min.bit(as.bit(x), range=range, ...)
2313         , hi=stop("not implemented")
2314         , ri=min.ri(x, range=range, ...)
2315  )
2316}
2317
2318#' @rdname Summaries
2319#' @export max.booltype
2320#' @export
2321max.booltype <- function(x, range=NULL, ...){
2322  switch(as.character(booltype(x))
2323         , nobool=max.bit(as.bit(x), range=range, ...)
2324         , logical=max.bit(as.bit(x), range=range, ...)
2325         , bit=max.bit(x, range=range, ...)
2326         , bitwhich=max.bitwhich(x, range=range, ...)
2327         , which=max.bit(as.bit(x), range=range, ...)
2328         , hi=stop("not implemented")
2329         , ri=max.ri(x, range=range, ...)
2330  )
2331}
2332
2333#' @rdname Summaries
2334#' @export range.booltype
2335#' @export
2336range.booltype <- function(x, range=NULL, ...){
2337  switch(as.character(booltype(x))
2338         , nobool=range.bit(as.bit(x), range=range, ...)
2339         , logical=range.bit(as.bit(x), range=range, ...)
2340         , bit=range.bit(x, range=range, ...)
2341         , bitwhich=range.bitwhich(x, range=range, ...)
2342         , which=range.bit(as.bit(x), range=range, ...)
2343         , hi=stop("not implemented")
2344         , ri=range.ri(x, range=range, ...)
2345  )
2346}
2347
2348#' @rdname Summaries
2349#' @export summary.booltype
2350#' @export
2351summary.booltype <- function(object, range=NULL, ...){
2352  switch(as.character(booltype(object))
2353         , nobool=summary.bit(as.bit(object), range=range, ...)
2354         , logical=summary.bit(as.bit(object), range=range, ...)
2355         , bit=summary.bit(object, range=range, ...)
2356         , bitwhich=summary.bitwhich(object, range=range, ...)
2357         , which=summary.bit(as.bit(object), range=range, ...)
2358         , hi=stop("not implemented")
2359         , ri=summary.ri(object, range=range, ...)
2360  )
2361}
2362
2363
2364#' Extract or replace part of an boolean vector
2365#'
2366#' Operators acting on \code{\link{bit}} or \code{\link{bitwhich}} objects to extract or replace parts.
2367#'
2368#' The typical usecase for for '[' and '[<-' is subscripting with positive integers,
2369#' negative integers are allowed but slower,
2370#' as logical subscripts only scalars are allowed.
2371#' The subscript can be given as a \code{\link{bitwhich}} object.
2372#' Also \code{\link{ri}} can be used as subscript.
2373#'
2374#' Extracting from \code{\link{bit}} and \code{\link{bitwhich}} is faster than from  \code{\link{logical}} if positive subscripts are used.
2375#' integer subscripts make sense.  Negative subscripts are converted to
2376#' positive ones, beware the RAM consumption.
2377#'
2378#' @name Extract
2379#' @param x a \code{\link{bit}} or \code{\link{bitwhich}} object
2380#' @param i preferrably a positive integer subscript or a \code{\link{ri}}, see text
2381#' @param value new logical or integer values
2382#' @return The extractors \code{[[} and \code{[} return a logical scalar or
2383#' vector.  The replacment functions return an object of \code{class(x)}.
2384#' @author Jens Oehlschlägel
2385#' @seealso \code{\link{bit}}, \code{\link[base]{Extract}}
2386#' @keywords classes logic
2387#' @examples
2388#'
2389#'   x <- as.bit(c(FALSE, NA, TRUE))
2390#'   x[] <- c(FALSE, NA, TRUE)
2391#'   x[1:2]
2392#'   x[-3]
2393#'   x[ri(1,2)]
2394#'   x[as.bitwhich(c(TRUE,TRUE,FALSE))]
2395#'   x[[1]]
2396#'   x[] <- TRUE
2397#'   x[1:2] <- FALSE
2398#'   x[[1]] <- TRUE
2399#'
2400NULL
2401
2402#' @rdname Extract
2403#' @export
2404"[[.bit" <- function(x, i){
2405  if (length(i)!=1L)
2406    stop("subscript length not 1")
2407  if (is.numeric(i)){
2408    i <- as.integer(i)
2409    if (is.na(i) || i<1L || i>length(x))
2410      stop("subscript must be positive integer (or double) within length")
2411    ret <- .Call(C_R_bit_extract, x, i)
2412    setattr(ret, "vmode", "boolean")
2413    ret
2414  }else
2415    stop("subscript must be positive integer (or double) within length")
2416}
2417
2418#' @rdname Extract
2419#' @export
2420"[[<-.bit" <- function(x, i, value){
2421  if (length(i)!=1L)
2422    stop("subscript length not 1")
2423  if (length(value)!=1)
2424    stop("value length not 1")
2425  if (is.numeric(i)){
2426    i <- as.integer(i)
2427    if (is.na(i) || i<1L)
2428      stop("subscript must be positive integer (or double)")
2429    if ((mi <- max(i))>length(x))
2430      length(x) <- mi
2431    value <- as.logical(value)
2432    .Call(C_R_bit_replace, x, i, value)
2433  }else
2434    stop("subscript must be positive integer (or double) within length")
2435}
2436
2437
2438#' @rdname Extract
2439#' @export
2440"[.bit" <- function(x, i){
2441  nx <- length(x)
2442  if ( missing(i) ){
2443    ret <- logical(nx)
2444    .Call(C_R_bit_get_logical, x, ret, range=c(1L, nx))
2445  }else{
2446    if (inherits(i, "bit")){
2447      i <- as.bitwhich(i)
2448    }
2449    if (inherits(i, "bitwhich")){
2450      i <- unclass(i)
2451    }
2452    if(is.numeric(i)){
2453      if (inherits(i, "ri")){
2454        if (i[1]<1L || i[2]>nx )
2455          stop("illegal range index 'ri'")
2456        ret <- logical(i[2]-i[1]+1L)
2457        .Call(C_R_bit_get_logical, x, ret, range=i)
2458      }else{
2459        i <- as.integer(i)
2460        r <- range_na(i)
2461        if (is.na(r[1])){
2462          ret <- logical()
2463        }else if (r[1]<0L){
2464          # check for positive or NA mixed with negative
2465          if (r[2]>0L || r[3]>0L)
2466            stop("only 0's may be mixed with negative subscripts")
2467          isasc <- intisasc(i, "none") # NAs checked already, early terminate on FALSE
2468          if (!isasc){
2469            if((length(i) / (r[2]-r[1])) < 0.05)
2470              i <- sort.int(i, method="quick")
2471            else
2472              i <- bit_sort_unique(i)
2473          }
2474        } # is positive, hence no sorting
2475        ret <- .Call(C_R_bit_extract, x, i)
2476      }
2477    }else if(is.logical(i)){
2478      if (poslength(i)==0L){
2479         ret <- logical()
2480      }else{
2481        if (inherits(i, "bitwhich")){
2482          i <- unclass(i)
2483        }else{
2484          if (length(i)!=1 || is.na(i))
2485            stop("only scalar TRUE or FALSE allowed")
2486        }
2487        if (i){
2488          ret <- logical(nx)
2489          .Call(C_R_bit_get_logical, x, ret, range=c(1L, nx))
2490        }else{
2491          ret <- logical()
2492        }
2493      }
2494    }else
2495      stop("subscript must be ri or integer (or double) or  TRUE (or missing) or FALSE")
2496  }
2497  setattr(ret, "vmode", "boolean")
2498  ret
2499}
2500
2501
2502#' @rdname Extract
2503#' @export
2504"[<-.bit" <- function(x, i, value){
2505  nx <- length(x)
2506  value <- as.logical(value)
2507  nv <- length(value)
2508  if (missing(i))
2509    i <- TRUE
2510  if (inherits(i, "bit")){
2511    i <- as.bitwhich(i)
2512  }
2513  if (inherits(i, "bitwhich")){
2514    i <- unclass(i)
2515  }
2516  if (is.logical(i)){
2517    if (length(i)!=1L || is.na(i))
2518      stop("logical only scalar TRUE or FALSE allowed")
2519    if (i){
2520      if (nv==0L)
2521        stop("replacement has length zero")
2522      if (nx %% nv)
2523        warning("number of items to replace is not a multiple of replacement length")
2524      .Call(C_R_bit_set_logical, x, value, range=c(1L, nx))
2525    }else{
2526      x
2527    }
2528  }else if(is.numeric(i)){
2529    if (inherits(i, "ri")){
2530      if (i[1]<1L)
2531        stop("illegal range index 'ri'")
2532      if (i[2]>nx)
2533        length(x) <- i[2]
2534      ni <- i[2] - i[1] + 1L
2535      if (nv==0L)
2536        stop("replacement has length zero")
2537      if (ni %% nv)
2538        warning("number of items to replace is not a multiple of replacement length")
2539      .Call(C_R_bit_set_logical, x, value, range=i)
2540    }else{
2541      if (inherits(i, "which")){
2542				ni <- length(i)
2543        if (ni && i[ni] > nx)
2544          length(x) <- i[ni]
2545			}else{
2546        i <- range_nanozero(as.integer(i))
2547        r <- getsetattr(i, "range_na", NULL)
2548        ni <- length(i)
2549				if (ni){
2550          if (r[3]>0L)
2551             stop("NAs are not allowed in subscripted assignments")
2552          if (r[1]>0L){
2553            if (r[2] > nx)
2554              length(x) <- r[2]
2555          }else{
2556            if (r[2] > 0L)
2557              stop("only 0's may be mixed with negative subscripts")
2558            # R_bit_replace expects sorted i if i is negative
2559            i <- bit_sort_unique(i, range_na = r)
2560            ni <- nx - length(i)
2561          }
2562				}
2563			}
2564      if (nv != ni){
2565        if (nv==0L)
2566          stop("replacement has length zero")
2567        if (ni %% nv)
2568          warning("number of items to replace is not a multiple of replacement length")
2569
2570      }
2571      .Call(C_R_bit_replace, x, i, value)
2572    }
2573  }else  stop("subscript must be integer (or double) or ri or bitwhich or TRUE or FALSE or missing")
2574}
2575
2576
2577#' Check existence of integers in table
2578#'
2579#' If the table is sorted, this can be much faster than \code{\link{\%in\%}}
2580#'
2581#' @param x a vector of integer
2582#' @param table a \code{\link{bitwhich}} object or a vector of integer
2583#' @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}
2584#'
2585#' @return logical vector
2586#' @seealso \code{\link{\%in\%}}
2587#'
2588#' @examples
2589#' x <- bitwhich(100)
2590#' x[3] <- TRUE
2591#' in.bitwhich(c(NA,2,3), x)
2592#' @export
2593in.bitwhich <- function(x, table, is.unsorted=NULL){
2594  x <- as.integer(x)
2595  if (is.null(is.unsorted))
2596    is.unsorted <- !is.bitwhich(table)
2597  if (is.logical(table)){
2598    if (length(table) && table){
2599      1L <= x & x <= length(table)
2600    }else{
2601      rep(FALSE, length(x))
2602    }
2603  }else{
2604    y <- bitwhich_representation(table)
2605    if (length(x)>1L && is.unsorted){
2606      if (y[1]>0L)
2607        !is.na(match(x,table))
2608      else
2609        is.na(match(-x,table))
2610
2611    }else{
2612      if (y[1]>0L)
2613        merge_in(x,table)
2614      else
2615        merge_notin(x,table, revy=TRUE)
2616    }
2617  }
2618}
2619
2620
2621#' @rdname Extract
2622#' @export
2623"[[.bitwhich" <- function(x, i){
2624  if (length(i)!=1L)
2625    stop("subscript length not 1")
2626  if (is.numeric(i)){
2627    i <- as.integer(i)
2628    if (is.na(i) || i<1L || i>length(x))
2629      stop("subscript must be positive integer (or double) within length")
2630    y <- bitwhich_representation(x)
2631    if (is.logical(y))
2632      ret <- as.vector(x)
2633    else{
2634      ret <- in.bitwhich(i, x)
2635    }
2636    setattr(ret, "vmode", "boolean")
2637    ret
2638  }else
2639    stop("subscript must be positive integer (or double) within length")
2640}
2641
2642
2643
2644#' @rdname Extract
2645#' @export
2646"[[<-.bitwhich" <- function(x, i, value){
2647  if (length(i)!=1L)
2648    stop("subscript length not 1")
2649  if (length(value)!=1L)
2650    stop("value length not 1")
2651  value <- as.logical(value)
2652  if (is.na(value))
2653    value <- FALSE
2654  n <- length(x)
2655  if (i>n)
2656    warning("increasing length of bitwhich, which has non-standard semantics")
2657  if (is.numeric(i)){
2658    i <- as.integer(i)
2659    if (is.na(i) || i<1L || i>.Machine$integer.max)
2660      stop("subscript must be positive integer (or double)")
2661    y <- bitwhich_representation(x)
2662    if (is.logical(y)){
2663      if (length(y)){
2664        if (value == y){
2665          if (i>n)
2666            length(x) <- i
2667          return(x)
2668        }else if (value)
2669          ret <- bitwhich(max(n,i), i, poslength=1L)
2670        else
2671          ret <- bitwhich(max(n,i), -i, poslength=n-1L)
2672      }else{
2673        if (value)
2674          ret <- bitwhich(i, i, poslength=1L)
2675        else
2676          ret <- bitwhich(i, -i, poslength=n-1L)
2677      }
2678    }else{
2679      if (i>n){
2680        n <- i
2681        length(x) <- i
2682      }
2683      oldvalue <- in.bitwhich(i, x)
2684      if (value == oldvalue)
2685        return(x)
2686      else{
2687        if (value == (y>0)){
2688          ret <- bitwhich(n, merge_union(x, y*i, method = "all"), poslength=attr(x, "poslength")+y)
2689        }else{
2690          ret <- bitwhich(n, merge_setdiff(x, y*i, method = "exact"), poslength=attr(x, "poslength")-y)
2691        }
2692      }
2693    }
2694  }else
2695    stop("subscript must be positive integer (or double) within length")
2696  a <- attributes(x)
2697  a$poslength <- attr(ret, "poslength")
2698  setattributes(ret, a)
2699  ret
2700}
2701
2702
2703#' @rdname Extract
2704#' @export
2705"[.bitwhich" <- function(x, i){
2706  nx <- length(x)
2707  if ( missing(i) ){
2708    ret <- as.logical(x)
2709  }else{
2710    if (inherits(i, "bit"))
2711      stop("please use as.which(bit) for subscripting with bit")
2712    if (inherits(i, "bitwhich"))
2713      stop("please use unclass(bitwhich) or as.which(bitwhich) to clarify what you want")
2714    if (length(i)==0){
2715      ret <- logical()
2716    }else{
2717      if(is.logical(i)){
2718        if (length(i)!=1L || is.na(i))
2719          stop("only scalar TRUE or FALSE allowed")
2720        if (i){
2721          ret <- as.logical(x)
2722        }else{
2723          ret <- logical()
2724        }
2725      }else if(is.numeric(i)){
2726        if (inherits(i, "ri")){
2727          if (i[1]<1L || i[2]>nx )
2728            stop("illegal range index 'ri'")
2729          if (is.logical(x)){
2730            if (length(x))
2731              ret <- rep(copy_vector(x), i[2]-i[1]+1L)
2732            else
2733              ret <- rep(NA, i[2]-i[1]+1L)
2734          }else{
2735            #y <- unclass(x)
2736            y <- bitwhich_representation(x)
2737            if (y[1]>0L){
2738              #ret <- rep(FALSE, i[2]-i[1]+1L)
2739              #ret[y[i[1]<=y & y<=i[2]] - i[1] + 1L] <- TRUE
2740              ret <- merge_rangein(c(i[1], i[2]), x)
2741            }else{
2742              # ret <- rep(TRUE, i[2]-i[1]+1L)
2743              # ret[-y[(-i[1])>=y & y>=(-i[2])] - i[1] + 1L] <- FALSE
2744              ret <- merge_rangenotin(c(i[1], i[2]), x, revy=TRUE)
2745            }
2746          }
2747        }else{
2748          i <- range_nanozero(as.integer(i))
2749          r <- getsetattr(i, "range_na", NULL)
2750          n <- length(i)
2751          if (r[3]==n) # if allNA
2752            ret <- rep(NA, n)
2753          else{
2754            if (r[1] < 0L && r[2] > 0L)
2755              stop("only 0's may be mixed with negative subscripts")
2756            ret <- as.bit(x)[i]
2757          }
2758        }
2759      }else stop("subscript must be integer (or double) or ri or bitwhich or TRUE or FALSE or missing")
2760    }
2761  }
2762  setattr(ret, "vmode", "boolean")
2763  ret
2764}
2765
2766
2767#' @rdname Extract
2768#' @export
2769"[<-.bitwhich" <- function(x, i, value){
2770  nx <- length(x)
2771  value <- as.logical(value)
2772  if (anyNA(value))
2773    value[is.na(value)] <- FALSE
2774  nv <- length(value)
2775  if (missing(i))
2776    i <- TRUE
2777  if (inherits(i, "bit"))
2778    stop("please use as.which(bit) for subscripting with bit")
2779  if (inherits(i, "bitwhich"))
2780    stop("please use unclass(bitwhich) or as.which(bitwhich) to clarify what you want")
2781  if (length(i)){
2782    if (is.logical(i)){
2783      if (length(i)!=1L || is.na(i))
2784        stop("logical only scalar TRUE or FALSE allowed")
2785      if (i){
2786        if (nv==1L){
2787          ret <- bitwhich(nx, value)
2788        }else{
2789          b <- as.bit(value)
2790          if (nv==nx){
2791            ret <- as.bitwhich(b)
2792          }else{
2793            if (nv==0L)
2794              stop("replacement has length zero")
2795            if (nx%%nv)
2796              warning("number of items to replace is not a multiple of replacement length")
2797            ret <- as.bitwhich(rep(b, length.out=nx))
2798          }
2799        }
2800      }else{
2801        return(x)
2802      }
2803    }else if(is.numeric(i)){
2804      if (nv>1L){
2805        b <- as.bit(x)
2806        b[i] <- value
2807        ret <- as.bitwhich(b)
2808      }else{
2809        if (inherits(i, "ri")){
2810          if (i[1]<1L)
2811            stop("illegal range index 'ri'")
2812          biggest_mentioned_index <- max(abs(i[1:2]))
2813          i <- i[1]:i[2]
2814          ni <- length(i)
2815        }else{
2816          if (inherits(i, "which")){
2817            ni <- length(i)
2818            biggest_mentioned_index <- i[length(i)]
2819          }else{
2820            i <- range_nanozero(as.integer(i))
2821            r <- getsetattr(i, "range_na", NULL)
2822            if (length(i)){
2823              if (r[3]>0L)
2824                stop("NAs are not allowed in subscripted assignments")
2825              if (r[1]>0L){
2826                # since value is a scalar removing duplicates does not harm and speeds up
2827                i <- bit_sort_unique(i, range_na = r)
2828                ni <- length(i)
2829              }else{
2830                if (r[2] > 0L)
2831                  stop("only 0's may be mixed with negative subscripts")
2832                i <- bit_sort_unique(i, range_na = r)
2833                ni <- nx - length(i)
2834              }
2835              # since value is a scalar removing duplicates does not harm and speeds up
2836              biggest_mentioned_index <- max(abs(i[1:2]), na.rm=TRUE)
2837            }else{
2838              ni <- 0L
2839              biggest_mentioned_index <- 0L
2840            }
2841          }
2842        }
2843        if (!ni){
2844          return(x)
2845        }else{
2846          if (nv==0L)
2847            stop("replacement has length zero")
2848          if (biggest_mentioned_index>nx){
2849            length(x) <- biggest_mentioned_index
2850            nx <- biggest_mentioned_index
2851          }
2852          y <- bitwhich_representation(x)
2853          if (is.logical(y)){
2854            if (value == y){
2855              # assignment doesn't change anything
2856              return(x)
2857            }else{
2858              if (value){
2859                # assignment has first inclusions
2860                if (i[1]<0){
2861                  # assignment enumerates those not included
2862                  ret <- bitwhich(nx, i, poslength=nx-length(i))
2863                }else{
2864                  # assignment enumerates those included
2865                  ret <- bitwhich(nx, i, poslength=length(i))
2866                }
2867              }else{
2868                # assignment has first exclusions
2869                if (i[1]<0){
2870                  # assignment enumerates those not excluded
2871                  ret <- bitwhich(nx, copy_vector(i, revx=TRUE), poslength=length(i))
2872                }else{
2873                  # assignment enumerates those excluded
2874                  ret <- bitwhich(nx, copy_vector(i, revx=TRUE), poslength=nx-length(i))
2875                }
2876              }
2877            }
2878          }else{
2879            if (y<0){
2880              # object maintains exclusions
2881              if (value){
2882                # assignment has inclusions
2883                if (i[1]<0){
2884                  # assignment enumerates those not included
2885                  # w2 <- w <- bitwhich(12, -(1:3)); w2[-(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
2886                  ret <- bitwhich(nx, merge_intersect(x,i, method='exact'), xempty=TRUE, is.unsorted = FALSE, has.dup = FALSE) #done
2887                }else{
2888                  # assignment enumerates those included
2889                  # w2 <- w <- bitwhich(12, -(1:3)); w2[(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
2890                  ret <- bitwhich(nx, merge_setdiff(x,i,revy=TRUE, method='exact'), xempty=TRUE, is.unsorted = FALSE, has.dup = FALSE)  #done
2891                }
2892              }else{
2893                # assignment has exclusions
2894                if (i[1]<0){
2895                  # assignment enumerates those not excluded
2896                  # w2 <- w <- bitwhich(12, -(1:3)); w2[-(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
2897                  ret <- bitwhich(nx, merge_setdiff(i, x, revx=TRUE, revy=TRUE, method='exact'), xempty=FALSE, is.unsorted = FALSE, has.dup = FALSE) #done
2898                }else{
2899                  # assignment enumerates those excluded
2900                  # w2 <- w <- bitwhich(12, -(1:3)); w2[(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
2901                  ret <- bitwhich(nx, merge_union(x,i,revy=TRUE, method='exact'), is.unsorted = FALSE, has.dup = FALSE) #done
2902                }
2903              }
2904            }else{
2905              # object maintains inclusions
2906              if (value){
2907                # assignment has inclusions
2908                if (i[1]<0){
2909                  # assignment enumerates those not included
2910                  # w2 <- w <- bitwhich(12, (1:3)); w2[-(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
2911                  ret <- bitwhich(nx, merge_setdiff(i,x, revy = TRUE, method='exact'), xempty=TRUE, is.unsorted = FALSE, has.dup = FALSE) #done
2912                }else{
2913                  # assignment enumerates those included
2914                  # w2 <- w <- bitwhich(12, (1:3)); w2[(3:5)] <- TRUE; cbind(as.logical(w), as.logical(w2))
2915                  ret <- bitwhich(nx, merge_union(x,i, method='exact'), is.unsorted = FALSE, has.dup = FALSE) #done
2916                }
2917              }else{
2918                # assignment has exclusions
2919                if (i[1]<0){
2920                  # assignment enumerates those not excluded
2921                  # w2 <- w <- bitwhich(12, (1:3)); w2[-(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
2922                  ret <- bitwhich(nx, merge_intersect(x, i, revy=TRUE, method='exact'), xempty=FALSE, is.unsorted = FALSE, has.dup = FALSE) #done
2923                }else{
2924                  # assignment enumerates those excluded
2925                  # w2 <- w <- bitwhich(12, (1:3)); w2[(3:5)] <- FALSE; cbind(as.logical(w), as.logical(w2))
2926                  ret <- bitwhich(nx, merge_setdiff(x,i, method='exact'), xempty=FALSE, is.unsorted = FALSE, has.dup = FALSE)
2927                }
2928              }
2929            }
2930          }
2931        }
2932      }
2933    }else  stop("subscript must be integer (or double) or ri or bitwhich or TRUE or FALSE or missing")
2934    a <- attributes(x)
2935    a$poslength <- sum(ret)
2936    setattributes(ret, a)
2937    ret
2938  }else
2939    x
2940}
2941
2942
2943
2944#' Range index
2945#'
2946#' A range index can be used to extract or replace a continuous ascending part
2947#' of the data
2948#'
2949#' @param from first position
2950#' @param to last posistion
2951#' @param x an object of class 'ri'
2952#' @param maxindex the maximal length of the object-to-be-subscripted (if
2953#' known)
2954#' @param \dots further arguments
2955#' @return A two element integer vector with class 'ri'
2956#' @author Jens Oehlschlägel
2957#' @seealso \code{\link[ff]{as.hi}}
2958#' @keywords classes logic
2959#' @examples
2960#'
2961#'  bit(12)[ri(1,6)]
2962#'
2963#' @export ri
2964ri <- function(from, to=NULL, maxindex=NA){
2965  if (is.null(to)){
2966    x <- as.integer(c(from, maxindex))
2967  }else{
2968    x <- as.integer(c(from, to, maxindex))
2969  }
2970  maxindex = maxindex
2971  if (length(x)!=3 )
2972    stop("range must have exactly three elements")
2973  if (x[[1]]<1L)
2974    stop("range must at least select one element")
2975  if (x[[1]]>x[[2]])
2976    stop("lower bound must be smaller or equal than upper bound")
2977  if (!is.na(x[[3]]) && x[[2]]>x[[3]])
2978    stop("lower and upper bound must be smaller or equal to maxindex")
2979  oldClass(x) <- c("booltype","ri")
2980  x
2981}
2982
2983#' @rdname ri
2984#' @export
2985print.ri <- function(x, ...)
2986  cat("range index (ri) from", x[[1]], "to", x[[2]], "maxindex",  x[[3]], "\n")
2987
2988#' @rdname length.bit
2989#' @export
2990length.ri <- function(x)x[[3]]
2991
2992
2993#' @rdname Summaries
2994#' @export
2995all.ri <- function(x, range=NULL, ...){
2996  if (is.null(range)){
2997    range[[1]] <- 1L
2998    range[[2]] <- x[[3]]
2999  }
3000  x[[1]]<=range[[1]] && x[[2]]>=range[[2]]
3001}
3002
3003#' @rdname Summaries
3004#' @export
3005any.ri <- function(x, range=NULL, ...){
3006  if (is.null(range)){
3007    range[[1]] <- 1L
3008    range[[2]] <- x[[3]]
3009  }
3010  range[[1]]<=x[[1]] && range[[2]]>=x[[2]]
3011}
3012
3013#' @rdname Summaries
3014#' @export
3015anyNA.ri <- function(x
3016                     #, range=NULL
3017                     , recursive = FALSE)FALSE
3018
3019#' @rdname Summaries
3020#' @export
3021sum.ri <- function(x, ...){
3022  if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
3023    stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
3024  x[[2]] - x[[1]] + 1L
3025}
3026
3027#' @rdname Summaries
3028#' @export
3029min.ri <- function(x, ...){
3030  if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
3031    stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
3032  x[[1]]
3033}
3034
3035#' @rdname Summaries
3036#' @export
3037max.ri <- function(x, ...){
3038  if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
3039    stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
3040  x[[2]]
3041}
3042
3043#' @rdname Summaries
3044#' @export
3045range.ri <- function(x, ...){
3046  if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
3047    stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
3048  x[1:2]
3049}
3050
3051#' @rdname Summaries
3052#' @export
3053summary.ri <- function(object, ...){
3054  if (any(names(match.call(expand.dots = TRUE))=="range") && !is.null(list(...)$range))
3055    stop("parameter 'range' allowed only for 'bit' but not for 'ri'")
3056  s <- object[[2]] - object[[1]] + 1L
3057   c(`FALSE` = object[[3]] - s, `TRUE` = s, Min. = object[[1]], Max. = object[[2]])
3058}
3059
3060
3061
3062# this version without vmode() will be overwritte by the version in package ff
3063#' @rdname PhysVirt
3064#' @export
3065physical.default <- function(x){
3066  p <- attributes(attr(x, "physical"))
3067  p <- p[is.na(match(names(p), "class"))]
3068  p
3069}
3070#' @rdname PhysVirt
3071#' @export
3072"physical<-.default" <- function(x, value){
3073  attributes(attr(x, "physical")) <- c(value, list(class="physical"))
3074  x
3075}
3076
3077
3078#' @rdname PhysVirt
3079#' @export
3080virtual.default <- function(x){
3081  v <- attributes(attr(x, "virtual"))
3082  v[is.na(match(names(v), "class"))]
3083}
3084#' @rdname PhysVirt
3085#' @export
3086"virtual<-.default" <- function(x, value){
3087  attributes(attr(x, "virtual")) <- c(value, list(class="virtual"))
3088  x
3089}
3090
3091
3092#' @rdname PhysVirt
3093#' @export
3094print.physical <- function(x, ...){
3095  cat("(hidden, use physical(x) to access the physical attributes and vmode(x) for accessing vmode)\n")
3096  invisible()
3097}
3098
3099#' @rdname PhysVirt
3100#' @export
3101print.virtual <- function(x, ...){
3102  cat("(hidden, use virtual(x) to access the virtual attributes)\n")
3103  invisible()
3104}
3105
3106
3107
3108
3109# not exported - just here to avoid cross calling the dll from ff
3110R_bit_as_hi <- function(x, range, offset)
3111.Call(C_R_bit_as_hi, x, range, offset)
3112
3113