~ubuntu-branches/ubuntu/wily/r-bioc-genomicranges/wily-proposed
» Revision
1
: R/GenomicRanges-class.R
« back to all changes in this revision
Viewing changes to R/GenomicRanges-class.R
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Package Import Robot
- Author(s): Andreas Tille
- Date: 2013-10-18 10:40:04 UTC
- Revision ID: package-import@ubuntu.com-20131018104004-ktm4ub0pcoybnir6
Tags: upstream-1.12.4
Import upstream version 1.12.4
- files added:
- R
- inst
- inst/doc
- inst/doc/precomputed_results
- inst/extdata
- inst/scripts
- inst/unitTests
- man
- src
- tests
added
removed
R/GenomicRanges-class.R
1
### =========================================================================
2
### The GenomicRanges interface
3
### -------------------------------------------------------------------------
4
###
5
6
### TODO: The 'constraint' slot could be moved to the Vector class (or to the
7
### Annotated class) so any Vector object could be constrained.
8
setClass("GenomicRanges",
9
contains="Vector",
10
representation(
11
"VIRTUAL"#,
12
#No more constraint slot for now...
13
#constraint="ConstraintORNULL"
14
)
15
)
16
17
setClassUnion("GenomicRangesORmissing", c("GenomicRanges", "missing"))
18
19
### The code in this file will work out-of-the-box on 'x' as long as
20
### seqnames(x), ranges(x), strand(x), seqlengths(x), seqinfo(),
21
### update(x) and clone(x) are defined.
22
23
24
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
25
### 2 non-exported low-level helper functions.
26
###
27
### For the 2 functions below, 'x' must be a GenomicRanges object.
28
### They both return a named integer vector where the names are guaranteed
29
### to be 'seqlevels(x)'.
30
###
31
32
minStartPerGRangesSequence <- function(x)
33
{
34
cil <- splitAsList(start(x), seqnames(x)) # CompressedIntegerList object
35
v <- Views(cil@unlistData, cil@partitioning) # XIntegerViews object
36
ans <- viewMins(v)
37
ans[width(v) == 0L] <- NA_integer_
38
names(ans) <- names(v)
39
ans
40
}
41
42
maxEndPerGRangesSequence <- function(x)
43
{
44
cil <- splitAsList(end(x), seqnames(x)) # CompressedIntegerList object
45
v <- Views(cil@unlistData, cil@partitioning) # XIntegerViews object
46
ans <- viewMaxs(v)
47
ans[width(v) == 0L] <- NA_integer_
48
names(ans) <- names(v)
49
ans
50
}
51
52
53
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
54
### Getters.
55
###
56
57
setMethod("length", "GenomicRanges", function(x) length(seqnames(x)))
58
59
setMethod("names", "GenomicRanges", function(x) names(ranges(x)))
60
61
#setMethod("constraint", "GenomicRanges", function(x) x@constraint)
62
63
64
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
65
### Validity.
66
###
67
### TODO: Should we enforce ranges(x) to be an IRanges *instance* (i.e.
68
### class(ranges(x) == "IRanges")) instead of just an IRanges *object* (i.e.
69
### is(ranges(x), "IRanges"))? Right now I can create a GRanges object where
70
### the ranges are a Views object on a very long DNAString subject with
71
### something like 'GRanges("chr1", Views(subject, start=1:2, end=5))'.
72
### Sounds cool but there are also some potential complications with this...
73
74
.valid.GenomicRanges.length <- function(x)
75
{
76
n <- length(seqnames(x))
77
if ((length(ranges(x)) != n)
78
|| (length(strand(x)) != n)
79
|| (nrow(mcols(x)) != n))
80
return("slot lengths are not all equal")
81
NULL
82
}
83
84
.valid.GenomicRanges.seqnames <- function(x)
85
{
86
if (!is.factor(runValue(seqnames(x))))
87
return("'seqnames' should be a 'factor' Rle")
88
if (IRanges:::anyMissing(runValue(seqnames(x))))
89
return("'seqnames' contains missing values")
90
NULL
91
}
92
93
.valid.GenomicRanges.ranges <- function(x)
94
{
95
if (class(ranges(x)) != "IRanges")
96
return("'ranges(x)' must be an IRanges instance")
97
NULL
98
}
99
100
.valid.GenomicRanges.strand <- function(x)
101
{
102
if (!is.factor(runValue(strand(x))) ||
103
!identical(levels(runValue(strand(x))), levels(strand())))
104
{
105
msg <- c("'strand' should be a 'factor' Rle with levels c(",
106
paste0('"', levels(strand()), '"', collapse=", "),
107
")")
108
return(paste(msg, collapse=""))
109
}
110
if (IRanges:::anyMissing(runValue(strand(x))))
111
return("'strand' contains missing values")
112
NULL
113
}
114
115
### NOTE: This list is also included in the man page for GRanges objects.
116
### Keep the 2 lists in sync!
117
### We don't put "genome" in that list in order to facilitate import of GFF3
118
### files as GRanges objects (see ?import.gff3 in rtracklayer).
119
INVALID.GR.COLNAMES <- c("seqnames", "ranges", "strand",
120
"seqlevels", "seqlengths", "isCircular",
121
#"genome",
122
"start", "end", "width", "element")
123
124
.valid.GenomicRanges.mcols <- function(x)
125
{
126
if (any(INVALID.GR.COLNAMES %in% colnames(mcols(x)))) {
127
msg <- c("names of metadata columns cannot be one of ",
128
paste0("\"", INVALID.GR.COLNAMES, "\"", collapse=", "))
129
return(paste(msg, collapse=" "))
130
}
131
NULL
132
}
133
134
### Also used by the validity method for GappedAlignments objects.
135
valid.GenomicRanges.seqinfo <- function(x)
136
{
137
x_seqinfo <- seqinfo(x)
138
if (!identical(seqlevels(x_seqinfo), levels(seqnames(x)))) {
139
msg <- c("'seqlevels(seqinfo(x))' and 'levels(seqnames(x))'",
140
"are not identical")
141
return(paste(msg, collapse=" "))
142
}
143
x_seqlengths <- seqlengths(x_seqinfo)
144
seqs_with_known_length <- names(x_seqlengths)[!is.na(x_seqlengths)]
145
if (length(seqs_with_known_length) == 0L)
146
return(NULL)
147
if (any(x_seqlengths < 0L, na.rm=TRUE))
148
return("'seqlengths(x)' contains negative values")
149
## We check only the ranges that are on a non-circular sequence with
150
## a known length.
151
x_isCircular <- isCircular(x_seqinfo)
152
non_circ_seqs <- names(x_isCircular)[!(x_isCircular %in% TRUE)]
153
ncswkl <- intersect(non_circ_seqs, seqs_with_known_length)
154
if (length(ncswkl) == 0L)
155
return(NULL)
156
x_seqnames <- seqnames(x)
157
runValue(x_seqnames) <- runValue(x_seqnames)[drop=TRUE]
158
minStarts <- minStartPerGRangesSequence(x)
159
maxEnds <- maxEndPerGRangesSequence(x)
160
if (any(minStarts[ncswkl] < 1L, na.rm=TRUE)
161
|| any(maxEnds[ncswkl] >
162
seqlengths(x)[ncswkl], na.rm=TRUE))
163
warning("'ranges' contains values outside of sequence bounds. ",
164
"See ?trim to subset ranges.")
165
NULL
166
}
167
168
.valid.GenomicRanges <- function(x)
169
{
170
c(.valid.GenomicRanges.length(x),
171
.valid.GenomicRanges.seqnames(x),
172
.valid.GenomicRanges.ranges(x),
173
.valid.GenomicRanges.strand(x),
174
.valid.GenomicRanges.mcols(x),
175
valid.GenomicRanges.seqinfo(x))
176
#checkConstraint(x, constraint(x)))
177
}
178
179
setValidity2("GenomicRanges", .valid.GenomicRanges)
180
181
182
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
183
### Coercion.
184
###
185
186
setAs("GenomicRanges", "RangedData",
187
function(from)
188
{
189
rd <- RangedData(ranges(from), strand=strand(from),
190
mcols(from), space=seqnames(from))
191
mcols(ranges(rd)) <- DataFrame(seqlengths=seqlengths(from),
192
isCircular=isCircular(from),
193
genome=genome(from))
194
metadata(ranges(rd)) <- metadata(from)
195
metadata(ranges(rd))$seqinfo <- seqinfo(from)
196
rd
197
}
198
)
199
200
setAs("GenomicRanges", "RangesList",
201
function(from)
202
{
203
rl <- split(ranges(from), seqnames(from))
204
mcols_list <- split(DataFrame(strand=strand(from), mcols(from)),
205
seqnames(from))
206
rl <- mendoapply(function(ranges, metadata) {
207
mcols(ranges) <- metadata
208
ranges
209
}, rl, mcols_list)
210
mcols(rl) <- DataFrame(seqlengths=seqlengths(from),
211
isCircular=isCircular(from),
212
genome=genome(from))
213
metadata(rl) <- metadata(from)
214
metadata(rl)$seqinfo <- seqinfo(from)
215
rl
216
}
217
)
218
219
setMethod("as.data.frame", "GenomicRanges",
220
function(x, row.names=NULL, optional=FALSE, ...)
221
{
222
ranges <- ranges(x)
223
if (missing(row.names))
224
row.names <- names(x)
225
if (!is.null(names(x)))
226
names(x) <- NULL
227
data.frame(seqnames=as.factor(seqnames(x)),
228
start=start(x),
229
end=end(x),
230
width=width(x),
231
strand=as.factor(strand(x)),
232
as.data.frame(mcols(x), ...),
233
row.names=row.names,
234
stringsAsFactors=FALSE)
235
}
236
)
237
238
.fromSeqinfoToGRanges <- function(from)
239
{
240
if (any(is.na(seqlengths(from))))
241
stop("cannot create a GenomicRanges from a Seqinfo ",
242
"with NA seqlengths")
243
GRanges(seqnames(from),
244
IRanges(rep(1L, length(from)),
245
width=seqlengths(from),
246
names=seqnames(from)),
247
seqinfo=from)
248
}
249
250
setAs("Seqinfo", "GenomicRanges", .fromSeqinfoToGRanges)
251
252
253
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
254
### Setters.
255
###
256
257
setReplaceMethod("names", "GenomicRanges",
258
function(x, value)
259
{
260
names(ranges(x)) <- value
261
x
262
}
263
)
264
265
setReplaceMethod("seqnames", "GenomicRanges",
266
function(x, value)
267
{
268
if (!is(value, "Rle"))
269
value <- Rle(value)
270
if (!is.factor(runValue(value)))
271
runValue(value) <- factor(runValue(value))
272
if (!identical(levels(value), seqlevels(x)))
273
stop("levels of supplied 'seqnames' must be ",
274
"identical to 'seqlevels(x)'")
275
n <- length(x)
276
k <- length(value)
277
if (k != n) {
278
if ((k == 0L) || (k > n) || (n %% k != 0L))
279
stop(k, " elements in value to replace ", n, " elements")
280
value <- rep(value, length.out=n)
281
}
282
update(x, seqnames=value)
283
}
284
)
285
286
setReplaceMethod("ranges", "GenomicRanges",
287
function(x, value)
288
{
289
if (!is(value, "IRanges"))
290
value <- as(value, "IRanges")
291
n <- length(x)
292
k <- length(value)
293
if (k != n) {
294
if ((k == 0L) || (k > n) || (n %% k != 0L))
295
stop(k, " elements in value to replace ", n, "elements")
296
value <- rep(value, length.out=n)
297
}
298
update(x, ranges=value, check=FALSE)
299
}
300
)
301
302
normargGenomicRangesStrand <- function(strand, n)
303
{
304
if (!is(strand, "Rle"))
305
strand <- Rle(strand)
306
if (!is.factor(runValue(strand))
307
|| !identical(levels(runValue(strand)), levels(strand())))
308
runValue(strand) <- strand(runValue(strand))
309
k <- length(strand)
310
if (k != n) {
311
if (k != 1L && (k == 0L || k > n || n %% k != 0L))
312
stop("supplied 'strand' has ", k, " elements (", n, " expected)")
313
strand <- rep(strand, length.out=n)
314
}
315
strand
316
}
317
318
setReplaceMethod("strand", "GenomicRanges",
319
function(x, value)
320
{
321
value <- normargGenomicRangesStrand(value, length(x))
322
x <- update(x, strand=value, check=FALSE)
323
msg <- .valid.GenomicRanges.strand(x)
324
if (!is.null(msg))
325
stop(msg)
326
x
327
}
328
)
329
330
setReplaceMethod("elementMetadata", "GenomicRanges",
331
function(x, ..., value)
332
{
333
value <- mk_elementMetadataReplacementValue(x, value)
334
x <- update(x, elementMetadata=value, check=FALSE)
335
msg <- .valid.GenomicRanges.mcols(x)
336
if (!is.null(msg))
337
stop(msg)
338
x
339
}
340
)
341
342
setReplaceMethod("seqinfo", "GenomicRanges",
343
function(x, new2old=NULL, force=FALSE, value)
344
{
345
if (!is(value, "Seqinfo"))
346
stop("the supplied 'seqinfo' must be a Seqinfo object")
347
dangling_seqlevels <- getDanglingSeqlevels(x,
348
new2old=new2old, force=force,
349
seqlevels(value))
350
if (length(dangling_seqlevels) != 0L)
351
x <- x[!(seqnames(x) %in% dangling_seqlevels)]
352
old_seqinfo <- seqinfo(x)
353
new_seqnames <- makeNewSeqnames(x, new2old=new2old, seqlevels(value))
354
x <- update(x, seqnames=new_seqnames, seqinfo=value, check=FALSE)
355
geom_has_changed <- sequenceGeometryHasChanged(seqinfo(x), old_seqinfo,
356
new2old=new2old)
357
if (any(geom_has_changed, na.rm=TRUE)) {
358
msg <- valid.GenomicRanges.seqinfo(x)
359
if (!is.null(msg))
360
stop(msg)
361
}
362
x
363
}
364
)
365
366
setMethod("score", "GenomicRanges", function(x) mcols(x)$score)
367
368
#setReplaceMethod("constraint", "GenomicRanges",
369
# function(x, value)
370
# {
371
# if (isSingleString(value))
372
# value <- new(value)
373
# if (!is(value, "ConstraintORNULL"))
374
# stop("the supplied 'constraint' must be a ",
375
# "Constraint object, a single string, or NULL")
376
# x@constraint <- value
377
# validObject(x)
378
# x
379
# }
380
#)
381
382
383
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
384
### Updating and cloning.
385
###
386
### An object is either 'update'd in place (usually with a replacement
387
### method) or 'clone'd (copied), with specified slots/fields overridden.
388
389
### For an object with a pure S4 slot representation, these both map to
390
### initialize. Reference classes will want to override 'update'. Other
391
### external representations need further customization.
392
393
setMethod("update", "GenomicRanges", # not exported
394
function(object, ..., check=TRUE)
395
{
396
initialize(object, ...)
397
}
398
)
399
400
setGeneric("clone", function(x, ...) standardGeneric("clone")) # not exported
401
402
setMethod("clone", "ANY", # not exported
403
function(x, ...)
404
{
405
if (nargs() > 1L)
406
initialize(x, ...)
407
else
408
x
409
}
410
)
411
412
413
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
414
### Ranges methods.
415
###
416
417
setMethod("start", "GenomicRanges", function(x, ...) start(ranges(x)))
418
setMethod("end", "GenomicRanges", function(x, ...) end(ranges(x)))
419
setMethod("width", "GenomicRanges", function(x) width(ranges(x)))
420
421
setReplaceMethod("start", "GenomicRanges",
422
function(x, check=TRUE, value)
423
{
424
if (!is.integer(value))
425
value <- as.integer(value)
426
ranges <- ranges(x)
427
starts <- start(ranges)
428
starts[] <- value
429
## TODO: Revisit this to handle circularity (maybe).
430
if (!IRanges:::anyMissing(seqlengths(x))) {
431
if (IRanges:::anyMissingOrOutside(starts, 1L)) {
432
warning("trimmed start values to be positive")
433
starts[starts < 1L] <- 1L
434
}
435
}
436
start(ranges, check=check) <- starts
437
update(x, ranges=ranges, check=FALSE)
438
}
439
)
440
441
setReplaceMethod("end", "GenomicRanges",
442
function(x, check=TRUE, value)
443
{
444
if (!is.integer(value))
445
value <- as.integer(value)
446
ranges <- ranges(x)
447
ends <- end(ranges)
448
ends[] <- value
449
seqlengths <- seqlengths(x)
450
## TODO: Revisit this to handle circularity.
451
if (!IRanges:::anyMissing(seqlengths)) {
452
seqlengths <- seqlengths[seqlevels(x)]
453
maxEnds <- seqlengths[as.integer(seqnames(x))]
454
trim <- which(ends > maxEnds)
455
if (length(trim) > 0L) {
456
warning("trimmed end values to be <= seqlengths")
457
ends[trim] <- maxEnds[trim]
458
}
459
}
460
end(ranges, check=check) <- ends
461
update(x, ranges=ranges, check=FALSE)
462
}
463
)
464
465
setReplaceMethod("width", "GenomicRanges",
466
function(x, check=TRUE, value)
467
{
468
if (!is.integer(value))
469
value <- as.integer(value)
470
if (!IRanges:::anyMissing(seqlengths(x))) {
471
end(x) <- start(x) + (value - 1L)
472
} else {
473
ranges <- ranges(x)
474
width(ranges, check=check) <- value
475
x <- update(x, ranges=ranges, check=FALSE)
476
}
477
x
478
}
479
)
480
481
482
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
483
### Subsetting and combining.
484
###
485
486
setMethod("[", "GenomicRanges",
487
function(x, i, j, ..., drop)
488
{
489
if (length(list(...)) > 0L)
490
stop("invalid subsetting")
491
if (missing(i) && missing(j))
492
return(x)
493
x_mcols <- mcols(x, FALSE)
494
if (missing(i)) {
495
ans_mcols <- x_mcols[ , j, drop=FALSE]
496
return(clone(x, elementMetadata=ans_mcols))
497
}
498
i <- IRanges:::normalizeSingleBracketSubscript(i, x)
499
ans_seqnames <- seqnames(x)[i]
500
ans_ranges <- ranges(x)[i]
501
ans_strand <- strand(x)[i]
502
if (missing(j)) {
503
ans_mcols <- x_mcols[i, , drop=FALSE]
504
} else {
505
ans_mcols <- x_mcols[i, j, drop=FALSE]
506
}
507
clone(x, seqnames=ans_seqnames,
508
ranges=ans_ranges,
509
strand=ans_strand,
510
elementMetadata=ans_mcols)
511
}
512
)
513
514
setReplaceMethod("[", "GenomicRanges",
515
function(x, i, j, ..., value)
516
{
517
if (!is(value, "GenomicRanges"))
518
stop("replacement value must be a GenomicRanges object")
519
seqinfo(x) <- merge(seqinfo(x), seqinfo(value))
520
seqnames <- seqnames(x)
521
ranges <- ranges(x)
522
strand <- strand(x)
523
ans_mcols <- mcols(x, FALSE)
524
if (!missing(i)) {
525
iInfo <- IRanges:::.bracket.Index(i, length(x), names(x))
526
if (!is.null(iInfo[["msg"]]))
527
stop(iInfo[["msg"]])
528
}
529
if (missing(i) || !iInfo[["useIdx"]]) {
530
seqnames[] <- seqnames(value)
531
ranges[] <- ranges(value)
532
strand[] <- strand(value)
533
if (missing(j))
534
ans_mcols[ , ] <- mcols(value, FALSE)
535
else
536
ans_mcols[ , j] <- mcols(value, FALSE)
537
} else {
538
i <- iInfo[["idx"]]
539
seqnames[i] <- seqnames(value)
540
ranges[i] <- ranges(value)
541
strand[i] <- strand(value)
542
if (missing(j))
543
ans_mcols[i, ] <- mcols(value, FALSE)
544
else
545
ans_mcols[i, j] <- mcols(value, FALSE)
546
}
547
update(x, seqnames=seqnames, ranges=ranges,
548
strand=strand, elementMetadata=ans_mcols)
549
}
550
)
551
552
### Not exported. 'x' *must* be an unnamed list of length >= 1 (not checked).
553
.unlist_list_of_GenomicRanges <- function(x, ignore.mcols=FALSE)
554
{
555
if (!isTRUEorFALSE(ignore.mcols))
556
stop("'ignore.mcols' must be TRUE or FALSE")
557
ans_class <- class(x[[1L]])
558
ans_seqinfo <- do.call(merge, lapply(x, seqinfo))
559
ans_seqnames <- do.call(c, lapply(x, seqnames))
560
ans_ranges <- do.call(c, lapply(x, ranges))
561
ans_strand <- do.call(c, lapply(x, strand))
562
if (ignore.mcols) {
563
ans_mcols <- new("DataFrame", nrows=length(ans_ranges))
564
} else {
565
ans_mcols <- do.call(rbind, lapply(x, mcols, FALSE))
566
}
567
new(ans_class, seqnames=ans_seqnames, ranges=ans_ranges, strand=ans_strand,
568
elementMetadata=ans_mcols, seqinfo=ans_seqinfo)
569
}
570
571
setMethod("c", "GenomicRanges",
572
function(x, ..., ignore.mcols=FALSE, .ignoreElementMetadata=FALSE,
573
recursive=FALSE)
574
{
575
if (!identical(recursive, FALSE))
576
stop("'recursive' argument not supported")
577
if (!isTRUEorFALSE(.ignoreElementMetadata))
578
stop("'.ignoreElementMetadata' must be TRUE or FALSE")
579
if (.ignoreElementMetadata) {
580
msg <- c("the '.ignoreElementMetadata' argument is defunct, ",
581
"please use 'ignore.mcols'\n instead")
582
.Defunct(msg=msg)
583
}
584
if (missing(x))
585
args <- unname(list(...))
586
else
587
args <- unname(list(x, ...))
588
.unlist_list_of_GenomicRanges(args, ignore.mcols=ignore.mcols)
589
}
590
)
591
592
setMethod("seqselect", "GenomicRanges",
593
function(x, start=NULL, end=NULL, width=NULL)
594
{
595
if (!is.null(end) || !is.null(width))
596
start <- IRanges(start=start, end=end, width=width)
597
irInfo <- IRanges:::.bracket.Index(start, length(x), names(x),
598
asRanges=TRUE)
599
if (!is.null(irInfo[["msg"]]))
600
stop(irInfo[["msg"]])
601
if (!irInfo[["useIdx"]])
602
return(x)
603
ir <- irInfo[["idx"]]
604
ranges <- seqselect(ranges(x), ir)
605
clone(x,
606
seqnames=seqselect(seqnames(x), ir),
607
ranges=ranges,
608
strand=seqselect(strand(x), ir),
609
elementMetadata=seqselect(elementMetadata(x, FALSE), ir))
610
}
611
)
612
613
setReplaceMethod("seqselect", "GenomicRanges",
614
function(x, start=NULL, end=NULL, width=NULL, value)
615
{
616
if (!is(value, "GenomicRanges"))
617
stop("replacement value must be a GenomicRanges object")
618
seqinfo(x) <- merge(seqinfo(x), seqinfo(value))
619
if (is.null(end) && is.null(width)) {
620
if (is.null(start))
621
ir <- IRanges(start=1L, width=length(x))
622
else if (is(start, "Ranges"))
623
ir <- start
624
else {
625
if (is.logical(start) && length(start) != length(x))
626
start <- rep(start, length.out=length(x))
627
ir <- as(start, "IRanges")
628
}
629
} else {
630
ir <- IRanges(start=start, end=end, width=width, names=NULL)
631
}
632
ir <- reduce(ir)
633
if (length(ir) == 0L) {
634
x
635
} else {
636
seqnames <- as.factor(seqnames(x))
637
ranges <- ranges(x)
638
strand <- as.factor(strand(x))
639
mcols <- mcols(x, FALSE)
640
seqselect(seqnames, ir) <- as.factor(seqnames(value))
641
seqselect(ranges, ir) <- ranges(value)
642
seqselect(strand, ir) <- as.factor(strand(value))
643
seqselect(mcols, ir) <- mcols(value)
644
update(x, seqnames=Rle(seqnames), ranges=ranges,
645
strand=Rle(strand),
646
elementMetadata=mcols)
647
}
648
}
649
)
650
651
setMethod("window", "GenomicRanges",
652
function(x, start=NA, end=NA, width=NA,
653
frequency=NULL, delta=NULL, ...)
654
{
655
update(x,
656
seqnames=window(seqnames(x), start=start, end=end,
657
width=width, frequency=frequency,
658
delta=delta),
659
ranges=window(ranges(x), start=start, end=end,
660
width=width, frequency=frequency,
661
delta=delta),
662
strand=window(strand(x), start=start, end=end,
663
width=width, frequency=frequency,
664
delta=delta),
665
elementMetadata=window(elementMetadata(x, FALSE),
666
start=start, end=end,
667
width=width, frequency=frequency,
668
delta=delta))
669
}
670
)
671
672
673
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
674
### $ and $<- methods
675
###
676
### Provided as a convenience, for GenomicRanges *only*, and as the result
677
### of strong popular demand.
678
### Note that those methods are not consistent with the other $ and $<-
679
### methods in the IRanges/GenomicRanges infrastructure, and might confuse
680
### some users by making them believe that a GenomicRanges object can be
681
### manipulated as a data.frame-like object.
682
### Therefore we recommend using them only interactively, and we discourage
683
### their use in scripts or packages. For the latter, use 'mcols(x)$name'
684
### instead of 'x$name'.
685
###
686
687
.DollarNames.GenomicRanges <- function(x, pattern)
688
grep(pattern, names(mcols(x)), value=TRUE)
689
690
setMethod("$", "GenomicRanges",
691
function(x, name) mcols(x)[[name]]
692
)
693
694
setReplaceMethod("$", "GenomicRanges",
695
function(x, name, value) {mcols(x)[[name]] <- value; x}
696
)
697
698
699
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
700
### "show" method.
701
###
702
703
.makeNakedMatFromGenomicRanges <- function(x)
704
{
705
lx <- length(x)
706
nc <- ncol(mcols(x))
707
ans <- cbind(seqnames=as.character(seqnames(x)),
708
ranges=IRanges:::showAsCell(ranges(x)),
709
strand=as.character(strand(x)))
710
if (nc > 0L) {
711
tmp <- do.call(data.frame, c(lapply(mcols(x),
712
IRanges:::showAsCell),
713
list(check.names=FALSE)))
714
ans <- cbind(ans, `|`=rep.int("|", lx), as.matrix(tmp))
715
}
716
ans
717
}
718
719
showGenomicRanges <- function(x, margin="",
720
with.classinfo=FALSE, print.seqlengths=FALSE)
721
{
722
lx <- length(x)
723
nc <- ncol(mcols(x))
724
cat(class(x), " with ",
725
lx, " ", ifelse(lx == 1L, "range", "ranges"),
726
" and ",
727
nc, " metadata ", ifelse(nc == 1L, "column", "columns"),
728
":\n", sep="")
729
out <- makePrettyMatrixForCompactPrinting(x,
730
.makeNakedMatFromGenomicRanges)
731
if (with.classinfo) {
732
.COL2CLASS <- c(
733
seqnames="Rle",
734
ranges="IRanges",
735
strand="Rle"
736
)
737
classinfo <- makeClassinfoRowForCompactPrinting(x, .COL2CLASS)
738
## A sanity check, but this should never happen!
739
stopifnot(identical(colnames(classinfo), colnames(out)))
740
out <- rbind(classinfo, out)
741
}
742
if (nrow(out) != 0L)
743
rownames(out) <- paste0(margin, rownames(out))
744
print(out, quote=FALSE, right=TRUE)
745
if (print.seqlengths) {
746
cat(margin, "---\n", sep="")
747
showSeqlengths(x, margin=margin)
748
}
749
}
750
751
setMethod("show", "GenomicRanges",
752
function(object)
753
showGenomicRanges(object, margin=" ",
754
with.classinfo=TRUE, print.seqlengths=TRUE)
755
)
756
Loggerhead is a web-based interface for Breezy
Version: 2.0.1