1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
### =========================================================================
### Utility functions for creating or modifying IRanges objects
### -------------------------------------------------------------------------
###
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### The "successiveIRanges" function.
###
### Note that the returned IRanges object is guaranteed to be normal in the
### following cases:
### (a) when length(width) == 0
### (b) when length(width) == 1 and width > 0
### (c) when length(width) >= 2 and all(width > 0) and all(gapwidth > 0)
### However, the function doesn't try to turn the result into a NormalIRanges
### object.
###
successiveIRanges <- function(width, gapwidth=0, from=1)
{
if (!is.numeric(width))
stop("'width' must be an integer vector")
if (length(width) == 0L)
return(IRanges())
if (!is.integer(width))
width <- as.integer(width) # this drops the names
else if (!is.null(names(width)))
names(width) <- NULL # unname() used to be broken on 0-length vectors
if (S4Vectors:::anyMissingOrOutside(width, 0L))
stop("'width' cannot contain NAs or negative values")
if (!is.numeric(gapwidth))
stop("'gapwidth' must be an integer vector")
if (!is.integer(gapwidth))
gapwidth <- as.integer(gapwidth)
if (S4Vectors:::anyMissing(gapwidth))
stop("'gapwidth' cannot contain NAs")
if (length(gapwidth) != length(width) - 1L) {
if (length(gapwidth) != 1L)
stop("'gapwidth' must a single integer or an integer vector ",
"with one less element than the 'width' vector")
gapwidth <- rep.int(gapwidth, length(width) - 1L)
}
if (!isSingleNumber(from))
stop("'from' must be a single integer")
if (!is.integer(from))
from <- as.integer(from)
ans_start <- cumsum(width[-length(width)] + gapwidth)
ans_start <- from + c(0L, ans_start)
## 'ans_start' could contain NAs in case of an integer overflow in
## cumsum(), hence the use of 'check=TRUE' here:
new2("IRanges", start=ans_start, width=width, check=TRUE)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### slidingIRanges()
###
slidingIRanges <- function(len, width, shift = 1L) {
start <- seq(1L, len-width, by=shift)
end <- seq(width, len, by=shift)
IRanges(start, end)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### breakInChunks()
###
### TODO: Should not be in IRanges-utils.R because it returns a
### PartitioningByEnd object, not an IRanges object. So move it to another
### file, e.g. to Partitioning-class.R. breakInChunks() is actually a
### specialized PartitioningByEnd constructor.
###
.normarg_totalsize <- function(totalsize)
{
if (!isSingleNumber(totalsize))
stop("'totalsize' must be a single integer")
if (!is.integer(totalsize))
totalsize <- as.integer(totalsize)
if (totalsize < 0L)
stop("'totalsize' cannot be negative")
totalsize
}
.normarg_nchunk_or_chunksize <- function(nchunk, totalsize, what)
{
if (!isSingleNumber(nchunk))
stop("'", what, "' must be a single integer")
if (!is.integer(nchunk))
nchunk <- as.integer(nchunk)
if (nchunk < 0L)
stop("'", what, "' cannot be negative")
if (nchunk == 0L && totalsize != 0L)
stop("'", what, "' can be 0 only if 'totalsize' is 0")
nchunk
}
breakInChunks <- function(totalsize, nchunk, chunksize)
{
totalsize <- .normarg_totalsize(totalsize)
if (!missing(nchunk)) {
if (!missing(chunksize))
stop("only one of 'nchunk' and 'chunksize' can be specified")
## All chunks will have more or less the same size, with the difference
## between smallest and biggest chunks guaranteed to be <= 1.
nchunk <- .normarg_nchunk_or_chunksize(nchunk, totalsize,
"nchunk")
if (nchunk == 0L)
return(PartitioningByEnd())
chunksize <- totalsize / nchunk # floating point division
breakpoints <- as.integer(cumsum(rep.int(chunksize, nchunk)))
## The last value in 'breakpoints' *should* be 'totalsize' but there is
## always some uncertainty about what coercing the result of a floating
## point operation to integer will produce. So we set this value
## manually to 'totalsize' just in case.
breakpoints[[nchunk]] <- totalsize
} else {
if (missing(chunksize))
stop("one of 'nchunk' and 'chunksize' must be specified")
## All chunks will have the requested size, except maybe the last one.
chunksize <- .normarg_nchunk_or_chunksize(chunksize, totalsize,
"chunksize")
if (totalsize == 0L)
return(PartitioningByEnd())
quot <- totalsize %/% chunksize # integer division
breakpoints <- cumsum(rep.int(chunksize, quot))
if (quot == 0L || breakpoints[[quot]] != totalsize)
breakpoints <- c(breakpoints, totalsize)
}
PartitioningByEnd(breakpoints)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### The "centeredIRanges" function.
###
centeredIRanges <- function(center, flank)
{
if (!is.numeric(center))
stop("'center' must be a numeric vector")
if (!is.numeric(flank))
stop("'flank' must be a numeric vector")
IRanges(start=center-flank, end=center+flank)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### The "whichAsIRanges" function.
###
### Note that unlike the standard which() function, whichAsIRanges() drops
### the names of 'x'.
###
whichAsIRanges <- function(x)
{
if (!is.logical(x))
stop("'x' must be a logical vector")
as(x, "NormalIRanges")
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Coercing an IRanges object to a NormalIRanges object.
###
asNormalIRanges <- function(x, force=TRUE)
{
if (!is(x, "IntegerRanges"))
stop("'x' must be an IntegerRanges object")
else if (!is(x, "IRanges"))
x <- as(x, "IRanges")
if (!isTRUEorFALSE(force))
stop("'force' must be TRUE or FALSE")
if (force)
x <- reduce(x, drop.empty.ranges=TRUE)
newNormalIRangesFromIRanges(x, check=!force)
}
.asNormalIRanges <- function(from) asNormalIRanges(from, force=TRUE)
setAs("IRanges", "NormalIRanges", .asNormalIRanges)
|
