R/FWIRanges-class.R
1aef3bd9
 # Internal classes -------------------------------------------------------------
 
 # The FWIRanges class is a simple container for storing a vector of fixed-width
 # integer ranges.
 # NOTE: The intention is to make this a fully-fledged IntegerRanges subclass
 #       that is part of the IRanges package. For now, this class is internal to
 #       bsseq and only a subset of methods are properly implemented.
 .FWIRanges <- setClass(
     "FWIRanges",
     contains = "IPosRanges",
     representation(
         start = "integer",
         width = "integer",
         NAMES = "character_OR_NULL"  # R doesn't like @names !!
     )
 )
 
 # # Validity methods -------------------------------------------------------------
 
 # TODO: Some of these may be redundant
 .valid.FWIRanges <- function(x) {
     msg <- NULL
     if (!is.integer(x@width)) {
         msg <- validMsg(msg, "'width' must be an integer.")
     }
     if (length(x@width) != 1L ) {
         msg <- validMsg(msg, "'width' must have length 1.")
     }
     if (x@width < 0) {
         msg <- validMsg(msg, "'width' must be non-negative.")
     }
 }
 
 setValidity2("FWIRanges", .valid.FWIRanges)
 
 # Internal methods -------------------------------------------------------------
 
d336f4cf
 setMethod("parallel_slot_names", "FWIRanges",
1aef3bd9
           function(x) c("start", "NAMES", callNextMethod())
 )
 
 setMethod("start", "FWIRanges", function(x, ...) x@start)
 
 setMethod("width", "FWIRanges", function(x) rep.int(x@width, length(x)))
 
 setMethod("end", "FWIRanges", function(x) {
     if (x@width == 1L) {
         x@start
     } else {
         width(x) - 1L + start(x)
     }
 })
 
 setMethod("names", "FWIRanges", function(x) x@NAMES)
 
 # TODO: Room for optmisation (e.g., write in C to reduce memory allocations).
 .set_FWIRanges_start <- function(x, value, check = TRUE) {
     if (!isTRUEorFALSE(check)) stop("'check' must be TRUE or FALSE")
     old_start <- start(x)
     new_start <- S4Vectors:::numeric2integer(value)
     new_width <- x@width - new_start + old_start
     if (any(new_width != new_width[1L])) {
         x <- as(x, "IRanges")
         start(x) <- value
         return(x)
     }
     x@width <- new_width[1L]
     if (check) validObject(x)
     x
 }
 
 setReplaceMethod(
     "start",
     "FWIRanges",
     function(x, ..., value) .set_FWIRanges_start(x, value)
 )
 
 .set_FWIRanges_end <- function(x, value, check = TRUE) {
     if (!isTRUEorFALSE(check)) stop("'check' must be TRUE or FALSE")
     new_width <- x@width + S4Vectors:::numeric2integer(value) - end(x)
     if (any(new_width != new_width[1L])) {
         x <- as(x, "IRanges")
         end(x) <- value
         return(x)
     }
     x@width <- new_width[1L]
     if (check) validObject(x)
     x
 }
 
 setReplaceMethod(
     "end",
     "FWIRanges",
     function(x, ..., value) .set_FWIRanges_end(x, value)
 )
 
 .set_FWIRanges_width <- function(x, value, check = TRUE) {
     if (!isTRUEorFALSE(check)) stop("'check' must be TRUE or FALSE")
     new_width <- S4Vectors:::numeric2integer(value)
     if (any(new_width != new_width[1L])) {
         x <- as(x, "IRanges")
         width(x) <- value
         return(x)
     }
     x@width <- new_width[1L]
     if (check) validObject(x)
     x
 }
 
 setReplaceMethod(
     "width",
     "FWIRanges",
     function(x, ..., value) .set_FWIRanges_width(x, value)
 )
 
 set_FWIRanges_names <- function(x, value) {
8691f7ab
     x@NAMES <- S4Vectors:::normarg_names(value, class(x), length(x))
1aef3bd9
     # NOTE: No need to validate an FWIRanges object after setting its names so
     #       this should be safe.
     x
 }
 
 setReplaceMethod("names", "FWIRanges", set_FWIRanges_names)
 
 setMethod("replaceROWS", "FWIRanges", function(x, i, value) {
     x_width <- x@width
     value_width <- value@width
     if (!identical(x_width, value_width)) {
         x <- as(x, "IRanges")
         value <- as(value, "IRanges")
         return(replaceROWS(x, i, value))
     }
     i <- normalizeSingleBracketSubscript(i, x, as.NSBS = TRUE)
     ans_start <- replaceROWS(start(x), i, start(value))
     ans_width <- value@width
     ans_mcols <- replaceROWS(mcols(x), i, mcols(value))
     BiocGenerics:::replaceSlots(
         x,
         start = ans_start,
         width = ans_width,
         mcols = ans_mcols,
         check = FALSE)
 })
 
 # TODO: Follow shift,IRanges-method
 setMethod("shift", "FWIRanges", function(x, shift = 0L, use.names = TRUE) {
     stopifnot(use.names)
     shift <- recycleIntegerArg(shift, "shift", length(x))
     new_start <- start(x) + shift
     # TODO: Use BiocGenerics:::replaceSlots()
     x@start <- new_start
     validObject(x)
     x
 })