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