[R] range segment exclusion using range endpoints

William Dunlap wdunlap at tibco.com
Sat May 12 23:09:17 CEST 2012


Here is some code that I've been fiddling with for years
(since I wanted to provide evidence that our main office
needed more modems and wanted to show how often
both of them were busy).  It does set operations and a
bit more on collections of half-open intervals.  (Hence
it drops zero-length intervals).

Several of the functions could be defined as methods
of standard set operators.

To see what it does try

   r1 <- as.Ranges(bottoms=c(1,3,5,7), tops=c(2, 4, 9, 8))
   r2 <- as.Ranges(bottoms=c(1.5,4,6,7), tops=c(1.7,5,7,9))
   setdiffRanges( as.Ranges(1, 5), as.Ranges(c(2, 3.5), c(3, 4.5)) )
   plot(r1, r2, setdiffRanges(r1,r2), intersectRanges(r1,r2), 
            unionRanges(r1,r2), c(r1,r2), inNIntervals(c(r1,r2), n=2))

You can use Date and POSIXct objects for the endpoints of
the intervals as well.

Bill Dunlap
Spotfire, TIBCO Software
wdunlap tibco.com

# An object of S3-class "Ranges" is a 2-column
# data.frame(bottoms, tops), describing a
# set of half-open intervals, (bottoms[i], tops[i]].
# inRanges is the only function that cares about
# the direction of the half-openness of those intervals,
# but the other rely on half-openness (so 0-width intervals
# are not allowed).

# Use as.Ranges to create a Ranges object from
#   * a matrix whose rows are intervals
#   * a data.frame whose rows are intervals
#   * a vector of interval starts and a vector of interval ends
# The endpoints must be of a class which supports the comparison (<,<=)
# operators and which can be concatenated with the c() function.
# That class must also be able to be in a data.frame and be subscriptable.
# That covers at least numeric, Data, and POSIXct.
# (The plot method only works for numeric endpoints).
# You may input a zero-width interval (with bottoms[i]==tops[i]),
# but the constructors will silently remove it.
as.Ranges <- function(x, ...) UseMethod("as.Ranges")

as.Ranges.matrix <- function(x, ...) {
    # each row of x is an interval
    stopifnot(ncol(x)==2, all(x[,1] <= x[,2]))
    x <- x[x[,1] < x[,2], , drop=FALSE]
    Ranges <- data.frame(bottoms = x[,1], tops = x[,2])
    class(Ranges) <- c("Ranges", class(Ranges))
    Ranges
}

as.Ranges.data.frame <- function(x, ...) {
    # each row of x is an interval
    stopifnot(ncol(x)==2, all(x[,1] <= x[,2]))
    x <- x[x[,1] < x[,2], , drop=FALSE]
    Ranges <- data.frame(bottoms = x[,1], tops = x[,2])
    class(Ranges) <- c("Ranges", class(Ranges))
    Ranges
}

as.Ranges.default <- function(bottoms, tops, ...) {
    # vectors of bottoms and tops of intervals
    stopifnot(all(bottoms <= tops))
    Ranges <- data.frame(bottoms=bottoms, tops=tops)[bottoms < tops, , drop=FALSE]
    class(Ranges) <- c("Ranges", class(Ranges))
    Ranges
}

c.Ranges <- function(x, ...) {
    # combine several Ranges objects into one which lists all the intervals.
    RangesList <- list(x=x, ...)
    Ranges <- x
    for (r in list(...)) {
        Ranges <- rbind(Ranges, r)
    }
    class(Ranges) <- unique(c("Ranges", class(Ranges)))
    Ranges
}

inNIntervals <- function(Ranges, n)
{
    # return Ranges object that describes points that are
    # in at least n intervals in the input Ranges object
    stopifnot(n>0)
    u <- c(Ranges[,1], Ranges[,2])
    o <- order(u)
    u <- u[o]
    jumps <- rep(c(+1L,-1L), each=nrow(Ranges))[o]
    val <- cumsum(jumps)
    as.Ranges(u[val==n & jumps==1], u[val==n-1 & jumps==-1])
}

unionIntervals <- function(Ranges) {
    # combine overlapping and adjacent intervals to create a
    # possibly smaller and simpler, but equivalent, Ranges object
    inNIntervals(Ranges, 1)
}

intersectIntervals <- function(Ranges) {
    # return 0- or 1-row Ranges object containing describing points
    # that are in all the intervals in input Ranges object.
    u <- unname(c(Ranges[,1], Ranges[,2]))
    o <- order(u)
    u <- u[o]
    jumps <- rep(c(+1L,-1L), each=nrow(Ranges))[o]
    val <- cumsum(jumps)
    as.Ranges(u[val==nrow(Ranges) & jumps==1], u[val==nrow(Ranges)-1 & jumps==-1])
}

unionRanges <- function(x, ...) {
    unionIntervals(rbind(x, ...))
}

setdiffRanges <- function (x, y) 
{
    # set difference: return Ranges object describing points that are in x but not y
    x <- unionIntervals(x)
    y <- unionIntervals(y)
    nx <- nrow(x)
    ny <- nrow(y)
    u <- c(x[, 1], y[, 1], x[, 2], y[, 2])
    o <- order(u)
    u <- u[o]
    vx <- cumsum(jx <- rep(c(1, 0, -1, 0), c(nx, ny, nx, ny))[o])
    vy <- cumsum(jy <- rep(c(0, -1, 0, 1), c(nx, ny, nx, ny))[o])
    as.Ranges(u[vx == 1 & vy == 0], u[(vx == 1 & jy == -1) | (jx == -1 & vy == 0)])
}

intersectRanges <- function(x, y)
{
    # return Ranges object describing points that are in both x and y
    x <- unionIntervals(x)
    y <- unionIntervals(y)
    nx <- nrow(x)
    ny <- nrow(y)
    u <- c(x[, 1], y[, 1], x[, 2], y[, 2])
    o <- order(u)
    u <- u[o]
    vx <- cumsum(jx <- rep(c(1, 0, -1, 0), c(nx, ny, nx, ny))[o])
    vy <- cumsum(jy <- rep(c(0, 1, 0, -1), c(nx, ny, nx, ny))[o])
    as.Ranges(u[vx == 1 & vy == 1], u[(vx == 1 & jy == -1) | (jx == -1 & vy == 1)])
}

inRanges <- function(x, Ranges)
{
    if (length(x) == 1) {
        any(x > Ranges[,1] & x <= Ranges[,2])
    } else {
        Ranges <- unionIntervals(Ranges)
        (findInterval(-x, rev(-as.vector(t(Ranges)))) %% 2) == 1
    }
}

plot.Ranges <- function(x, ...)
{
    # mainly for debugging - no plotting controls, all ... must be Ranges objects.
    RangesList <- list(x=x, ...)
    labels <- vapply(as.list(substitute(list(x, ...)))[-1], function(x)deparse(x)[1], "")
    oldmar <- par(mar = replace(par("mar"), 2, max(nchar(labels)/2, 10)))
    on.exit(par(oldmar))
    xlim <- do.call("range", c(unlist(RangesList, recursive=FALSE), list(finite=TRUE)))
    ylim <-  c(0, length(RangesList)+1)
    plot(type="n", xlim, ylim, xlab="", ylab="", axes=FALSE)
    grid(ny=0)
    axis(side=1)
    axis(side=2, at=seq_along(RangesList), lab=labels, las=1, tck=0)
    box()
    incr <- 0.45 / max(vapply(RangesList, nrow, 0))
    xr <- par("usr")[1:2] # for intervals that extend to -Inf or Inf.
    for(i in seq_along(RangesList)) {
        r <- RangesList[[i]]
        if (nrow(r)>0) {
            y <- i + seq(0, by=incr, len=nrow(r))
            r <- r[order(r[,1]),,drop=FALSE]
            segments(pmax(r[,1], xr[1]), y, pmin(r[,2], xr[2]), y)
        }
    }
}



> -----Original Message-----
> From: r-help-bounces at r-project.org [mailto:r-help-bounces at r-project.org] On Behalf
> Of Ben quant
> Sent: Saturday, May 12, 2012 10:54 AM
> To: r-help at r-project.org
> Subject: [R] range segment exclusion using range endpoints
> 
> Hello,
> 
> I'm posting this again (with some small edits). I didn't get any replies
> last time...hoping for some this time. :)
> 
> Currently I'm only coming up with brute force solutions to this issue
> (loops). I'm wondering if anyone has a better way to do this. Thank you for
> your help in advance!
> 
> The problem: I have endpoints of one x range (x_rng) and an unknown number
> of s ranges (s[#]_rng) also defined by the range endpoints. I'd like to
> remove the x ranges that overlap with the s ranges. The examples below
> demonstrate what I mean.
> 
> What is the best way to do this?
> 
> Ex 1.
> For:
> x_rng = c(-100,100)
> 
> s1_rng = c(-25.5,30)
> s2_rng = c(0.77,10)
> s3_rng = c(25,35)
> s4_rng = c(70,80.3)
> s5_rng = c(90,95)
> 
> I would get:
> -100,-25.5
> 35,70
> 80.3,90
> 95,100
> 
> Ex 2.
> For:
> x_rng = c(-50.5,100)
> 
> s1_rng = c(-75.3,30)
> 
> I would get:
> 30,100
> 
> Ex 3.
> For:
> x_rng = c(-75.3,30)
> 
> s1_rng = c(-50.5,100)
> 
> I would get:
> -75.3,-50.5
> 
> Ex 4.
> For:
> x_rng = c(-100,100)
> 
> s1_rng = c(-105,105)
> 
> I would get something like:
> NA,NA
> or...
> NA
> 
> Ex 5.
> For:
> x_rng = c(-100,100)
> 
> s1_rng = c(-100,100)
> 
> I would get something like:
> -100,-100
> 100,100
> or just...
> -100
>  100
> 
> PS - You may have noticed that in all of the examples I am including the s
> range endpoints in the desired results, which I can deal with later in my
> program so its not a problem...  I think leaving in the s range endpoints
> simplifies the problem.
> 
> Thanks!
> Ben
> 
> 	[[alternative HTML version deleted]]
> 
> ______________________________________________
> R-help at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
> and provide commented, minimal, self-contained, reproducible code.



More information about the R-help mailing list